SUBROUTINE CIGMBO(KFILDO,KFIL10,IP16,NDATE,ID,IDPARS,JD, 1 IDOBS,XDATA,FD2,FD3,ND1,NSTA, 2 NCAT,CONST,NSCAL, 3 IBSTRT,IBEND,CAP, 4 LSTORE,ND9,LITEMS, 5 IS0,IS1,IS2,IS4,ND7, 6 IPACK,IWORK,DATA,ND5, 7 CORE,ND10,NBLOCK,NSTORE,NFETCH, 8 L3264B,ISTOP,IER) C C FEBRUARY 2011 GLAHN MDL MOS-2000 C MARCH 2011 GLAHN MODIFIED TREATMENT OF CATEGORY 8 C APRIL 2011 GLAHN ADDED IDOBS( ),IP16 C APRIL 2011 GLAHN OMITTED DO 213 TEST LOOP C MAY 2011 GLAHN DIAGNOSTIC 1775 REMOVED; IFREQ( ) C INITIALIZED C JUNE 2013 IM MODIFIED FORMAT STATEMENT C 237 FOR INTEL COMPILER C JUNE 2013 IM FIXED TYPO OF "ERROR IN VISMBO" TO C "ERROR IN CIGMBO" C FEBRUARY 2015 GLAHN MODIFIED ALGORITHM IN DO 180 LOOP C AS A SAFETY BUT IT WAS WORKING OK; C COMMENTS; OTHER SLIGHT MODS; C CAPPED HEIGHTS AT CIGMAX=120 C FEBRUARY 2015 GLAHN MODIFIED AGAIN; CIGMAX DELETED C MARCH 2015 GLAHN EXTENDED FREQUENCY CATEGOREIS FROM C 15 TO 16; INSERTED GO TO 220 IN C DO 220 LOOP C SEPTEMBER 2015 GLAHN CHANGED 1.001 TO 1.01 BELOW 130; C CHANGED 1.999 TO 1.99 ABOVE 137 C SEPTEMBER 2015 GLAHN SIMILAR CHANGES ASSURE THE SCALED C VALUE MATCHES THE CATEGORY; CHANGED C "AND.FD3(K).LT.TABLE(2,J))" TO C "AND.FD3(K).LE.TABLE(2,J))"BELOW C 178 c SEPTEMBER 2015 GLAHN REMOVED GO TO 160 BELOW 130; ADDED C TO FORMAT 237; COMMENTS; REMOVED C DATA IFREQ/16*0/ AND ADDED DO 217 C C PURPOSE C TO POSTPROCESS SCALED CEILING HEIGHT CATEGORIES AT C STATIONS INTO A CONTINUOUS VARIABLE IN HUNDREDS OF FT C THEN POSSIBLY MODIFIED BY OBSERVATIONS. C C CATEGORY 7 DEFINES CEILING HEIGHT TO BE BETWEEN > 65 AND C < OR = 120 IN HUNDREDS OF FT (UNLESS CONST AND NSCAL C DICTATE OTHERWISE). CATEGORY 8 DURING DEVELOPMENT C INCLUDES ALL VALUES GREATER THAN 120 INCLUDING UNLIMITED. C THE LARGEST HEIGHT, UNLESS MODIFIED BY THE OB, C IS 120, THE VALUES IN CATEGORY 8 NEED TO BE > 120 TO GET C A BOUNDARY BETWEEN CATEGORIES 7 AND 8 IN THE ANALYSIS. C THE VALUE USED FOR THIS IS CAP, AN INPUT VARIABLE. C C AFTER THE CONVERSION OF LAMP CATEGORIES TO CEILING HEIGHT C IN HUNDREDS OF FT, THE CEILING HEIGHT OBS ARE USED TO C POSSIBLY MODIFY THE FORECAST VALUES. WHEN THE PROJECTION C IS LE IBSTRT, THE FORECAST IS REPLACED BY THE OBSERVATION C WHEN, AND ONLY WHEN, THE FORECAST CATEGORY ENCOMPASSES THE C OB. WHEN THE PROJECTION IS GT IBSTRT AND LT IBEND, THE C FORECAST IS REPLACED BY A WEIGHTED AVERAGE OF THE C FORECAST AND THE OB, WEIGHTED BY THE DISTANCE THE C PROJECTION IS FROM IBSTRT. WHEN THE PROJECTION IS C GE IBEND, THE FORECAST IS NOT MODIFIED BY THE OB. C THIS KEEPS THE FORECAST GRID AS CONSISTENT AS POSSIBLE C WITH THE OBSERVATION ANALYSIS AND STILL BE CONSISTENT C WITH THE FORECAST CATEGORIES AT SHORT PROJECTIONS, AND C GRADUALLY CUT LOOSE FROM THE OBS. C C BEFORE THE UNLIMITED VALUES ARE SET TO CAP FOR THE C ANALYSIS, THEY ARE WRITTEN TO THE INTERNAL RANDOM ACCESS C FILE WITH THE ID = THE INCOMING ID CCCFFF WITH C FFF = FFF+002. C C THE SCALED VALUES FOR CATEGORY J WILL BE J.000 TO J990 C COMING INTO CIGMBO FROM SCLCIG. NSCALE FOR CIG IS C NORMALLY 2, SO THOUSANDTHS CANNOT BE EXPECTED TO C SURVIVE PACKING. THIS ROUTINE EXPECTS NSCALE TO BE GE 2. C C THE VARIABLE IS THEN SCALED BY FACTOR=CONST*10.**NSCAL. C C CIGMBO IS CALLED FROM SCLCIG; CIGMBO = CEILING HEIGHT C MODIFIED BY OBSERVATIONS. C C DATA SET USE C KFILDO - UNIT NUMBER FOR OUTPUT (PRINT) FILE. (OUTPUT) C KFIL10 - UNIT NUMBER FOR INTERNAL RANDOM ACCESS STORAGE. C (INPUT) C IP16 - UNIT NUMBER FOR INDICATING WHEN A RECORD IS C WRITTEN TO THE SEQUENTIAL OR RANDOM ACCESS C FILE. (INPUT) C C VARIABLES C KFILDO = UNIT NUMBER FOR OUTPUT (PRINT) FILE. (INPUT) C KFIL10 = UNIT NUMBER FOR INTERNAL RANDOM ACCESS STORAGE. C (INPUT/OUTPUT) C IP16 = UNIT NUMBER FOR INDICATING WHEN A RECORD IS C WRITTEN TO THE SEQUENTIAL OR RANDOM ACCESS C FILE. (INPUT) C NDATE = DATE/TIME, YYYYMMDDHH, OF THE RUN. C (INPUT) C ID(J) = ID OF VARIABLE TO PROVIDE DATA FOR ANALYSIS C (J=1,4). (INPUT) C IDPARS(J) = THE PARSED, INDIVIDUAL COMPONENTS OF THE C VARIABLE ID'S CORRESPONDING TO ID( ,N) C (J=1,15), (N=1,ND4). C J=1--CCC (CLASS OF VARIABLE), C J=2--FFF (SUBCLASS OF VARIABLE), C J=3--B (BINARY INDICATOR), C J=4--DD (DATA SOURCE, MODEL NUMBER), C J=5--V (VERTICAL APPLICATION), C J=6--LBLBLBLB (BOTTOM OF LAYER, 0 IF ONLY C 1 LAYER), C J=7--LTLTLTLT (TOP OF LAYER), C J=8--T (TRANSFORMATION), C J=9--RR (RUN TIME OFFSET, ALWAYS + AND BACK C IN TIME), C J=10--OT (TIME APPLICATION), C J=11--OH (TIME PERIOD IN HOURS), C J=12--TAU (PROJECTION IN HOURS), C J=13--I (INTERPOLATION TYPE), C J=14--S (SMOOTHING INDICATOR), AND C J=15--G (GRID INDICATOR). C (INPUT) C JD(J) = THE BASIC INTEGER VARIABLE ID'S (J=1,4) C (N=1,ND4). C THIS IS THE SAME AS ID(J,N), EXCEPT THAT THE C PORTIONS PERTAINING TO PROCESSING ARE OMITTED: C B = IDPARS(3, ), C T = IDPARS(8,), C I = IDPARS(13, ), C S = IDPARS(14, ), C G = IDPARS(15, ), AND C THRESH( ). C NOT ACTUALLY USED. (INPUT) C IDOBS(J) = 4-WORD ID OF CEILING HEIGHT OBSERVATIONS C (ACTUALLY COMPUTED) FOR PERSISTENCE C AUGMENTATION (J=1,4). (INPUT) C XDATA(K) = SCALED CATEGORICAL VALUES ON INPUT; ACTUAL C VALUES IN HUNDREDS OF FT ON OUTPUT (K=1,NSTA). C (INPUT/OUTPUT) C FD2(K) = WORK ARRAY (K=1,ND1). HOLDS FORECASTS AS C THEY ARE BEING MODIFIED. (INTERNAL) C FD3(K) = WORK ARRAY (K=1,ND1). HOLDS OBS. (INTERNAL) C ND1 = SIZE OF SEVERAL VARIABLES. (INPUT) C NSTA = NUMBER OF VALUES BEING PROCESSED. THE NUMBER C OF VALUES IN XDATA( ). (INPUT) C NCAT = NUMBER OF CEILING HEIGHT CATEGORIES. C (INPUT) C CONST = THE MULTIPLIER FOR SCALING. (INPUT) C NSCAL = THE POWER OF TEN FOR SCALING. (INPUT) C IBSTRT = THE PROJECTION BELOW WHICH A FORECAST MAY BE C SET TO THE OBSERVATION VALUE. (INPUT) C IBEND = THE PROJECTION BELOW WHICH A FORECAST MAY BE C A COMBINATION OF THE FORECAST AND OBSERVATION. C (INPUT)- C CAP = THE VALUE TO USE FOR UNLIMITED FOR THE C ANALYSIS. (INPUT) C LSTORE(L,J) = THE ARRAY HOLDING INFORMATION ABOUT THE DATA C STORED (L=1,12) (J=1,LITEMS). (INPUT/OUTPUT) C ND9 = MAXIMUM NUMBER OF FIELDS STORED IN LSTORE( , ). C SECOND DIMENSION OF LSTORE( , ). (INPUT) C LITEMS = THE NUMBER OF ITEMS J IN LSTORE( ,L). C (INPUT/OUTPUT) C IS0(J) = MOS-2000 GRIB SECTION 0 ID'S (J=1,4). C IS1(J) = MOS-2000 GRIB SECTION 1 ID'S (J=1,21+). C IS2(J) = MOS-2000 GRIB SECTION 2 ID'S (J=1,12). C IS4(J) = MOS-2000 GRIB SECTION 4 ID'S (J=1,4). C ND7 = DIMENSION OF IS0( ), IS1( ), IS2( ), AND IS4( ). C (INPUT) C IPACK(J) = WORK ARRAY FOR GFETCH (J=1,ND5). (INTERNAL) C IWORK(J) = WORK ARRAY FOR GFETCH (J=1,ND5). (INTERNAL) C DATA(J) = WORK ARRAY FOR GFETCH (J=1,ND5). C (INTERNAL) C ND5 = DIMENSION OF IPACK( ), WORK( ), AND DATA( ). C (INPUT) C CORE(J) = SPACE ALLOCATED FOR SAVING PACKED GRIDPOINT C FIELDS (J=1,ND10). WHEN THIS SPACE IS C EXHAUSTED, SCRATCH DISK WILL BE USED. THIS IS C THE SPACE USED FOR THE MOS-2000 INTERNAL RANDOM C ACCESS SYSTEM. (INPUT) C ND10 = THE MEMORY IN WORDS ALLOCATED TO THE SAVING OF C DATA CORE( ). WHEN THIS SPACE IS EXHAUSTED, C SCRATCH DISK WILL BE USED. (INPUT) C NBLOCK = BLOCK SIZE IN WORDS OF INTERNAL MOS-2000 DISK C STORAGE. (INPUT) C NSTORE = NUMBER OF TIMES A RECORD HAS BEEN STORED TO C INTERNAL STORAGE. (INPUT/OUTPUT) C NFETCH = NUMBER OF TIMES A RECORD HAS BEEN FETCHED FROM C INTERNAL STORAGE. (INPUT/OUTPUT) C L3264B = INTEGER WORD LENGTH IN BITS OF MACHINE BEING C USED (EITHER 32 OR 64). (INPUT) C ISTOP(J) = ISTOP(1) IS INCREMENTED BY 1 WHENEVER AN ERROR C OCCURS AND THE PROGRAM PROCEEDS. ISTOP(3) IS C INCREMENTED BY 1 WHEN A DATA RECORD COULD C NOT BE FOUND. WHEN AN ERROR OCCURS AND IER IS C RETURNED NE 0, THE INCREMENTING OF ISTOP(1) C IS DONE IN THE CALLING PROGRAM (U405A). C (INPUT/OUTPUT) C IER = ERROR CODE. C 0 = GOOD RETURN. C 777 = NCAT NE NOCAT. C OTHER VALUES FROM CALLED ROUTNES. EVERY C ERROR IS FATAL FOR THIS ELEMENT. C (OUTPUT) C NOCAT = SET TO NUMBER OF CATEGORIES, WHICH MUST BE C INCOMING NCAT. NOCAT HAS TO BE DEFINED AS C A PARAMETER IN ORDER TO INITIALIZE TABLE( , ). C (INTERNAL) C TABLE(J,M) = HOLDS THE LOWER AND UPPER CATEGORY BREAKPOINTS C FOR THE NCAT CATEGORIES OF CEILING HEIGHT C (M=1,NOCAT), (J=1,2). (INTERNAL) SET BY DATA C STATEMENT. C C THE CEILING HEIGHT CATEGORIES ARE: C C CAT VALUES C 1 < 2 C 2 2 - 4 C 3 5 - 9 C 4 10 - 19 C 5 20 - 30 C 6 31 - 65 C 7 66 - 120 C 8 > 120 (+ UNLIMITED AND UNDETERMINED) C WHILE HEIGHTS ARE NOT OBSERVED IN FRACTIONS OF C HUNDREDS OF FEET, THE FORECASTS ARE SCALED TO C FRACTIONS. THE UPPER LIMIT IS CONSIDERED THE C LIMIT OF THE CATEGORY, AND ANYTHING GT THAT IS C CONSIDERED TO BE IN THE NEXT CATEGORY ABOVE. C X888 = 888 TO INDICATE UNLIMITED CEILING. (INTERNAL) C TEST(K) = HOLDS THE INCOMING FORECASTS SO THAT THE C CATEGORY NUMBER CAN BE RETRIEVED AFTER SCALING C TO HUNDREDS OF FT. (INTERNAL) C 1 2 3 4 5 6 7 X C C NONSYSTEM SUBROUTINES USED C NONE C PARAMETER (NOCAT=8) C CHARACTER*32 PLANT C DIMENSION ID(4),IDPARS(15),JD(4),IDOBS(4) DIMENSION XDATA(ND1),FD3(ND1),FD2(ND1),TEST(ND1) C TEST( ) IS AN AUTOMATIC ARRAY. DIMENSION IPACK(ND5),IWORK(ND5),DATA(ND5) DIMENSION IS0(ND7),IS1(ND7),IS2(ND7),IS4(ND7) DIMENSION LSTORE(12,ND9) DIMENSION CORE(ND10) DIMENSION TABLE(2,NOCAT) DIMENSION FREQ(16),IFREQ(16),RFREQ(16),ISTOP(6),LD(4) C DATA PLANT/' LMP CEILING HEIGHT IN HDS OF FT'/ DATA FREQ/1.,2.,3.,4.,5.,7.,9.,15.,19.,30.,50.,65.,100.,120., 1 130.,999./ DATA X888/888./ C DATA TABLE/ 0., 1.999, 2 2., 4., 3 5., 9., 4 10., 19., 5 20., 30., 6 31., 65., 7 66., 120., 8 120., 99999./ C THESE CATEGORY BOUNDS DO NOT HAVE TO COVER THE FULL RANGE OF C VALUES. THEY ARE THE CATEGORY LIMITS. NOTE THIS IS NOT C THE SAME TABLE PHILLSOPHY AS USED IN VISMBO. THERE WILL C BE NO SCALED VALUES, FOR INSTANCE, BETWEEN 19.01 AND 19.99. C CALL TIMPR(KFILDO,KFILDO,'START CIGMBO ') IER=0 C D WRITE(KFILDO,102)CONST,NSCAL,CAP,IBSTRT,IBEND,IDPARS(12) D102 FORMAT(/' AT 102 IN CIGMBO--CONST,NSCAL,CAP,', D 1 'IBSTRT,IBEND,IDPARS(12)',F10.4,I4,F6.1,3I4) C CCCC WRITE(KFILDO,105)(XDATA(K),K=1,NSTA) CCCC 105 FORMAT(/,' IN CIGMBO AT 105--XDATA(K)',/,(15F8.2)) C IF(NOCAT.NE.NCAT)THEN WRITE(KFILDO,107)NCAT,NOCAT 107 FORMAT(/' ****INCOMING NCAT =',I4,' NOT EQUAL TO INTERNAL', 1 ' NOCAT =',I4,'. FATAL ERROR.') ISTOP(1)=ISTOP(1)+1 IER=777 GO TO 240 ENDIF C IF(IBEND.LT.IBSTRT)THEN WRITE(KFILDO,110)IBSTRT,IBEND 110 FORMAT(/' ****IBSTRT =',I4,' SHOULD BE LE IBEND =',I4, 1 '. IBEND SET = IBSTRT. PROCEEDING.') IBEND=IBSTRT ISTOP(1)=ISTOP(1)+1 ENDIF C C TURN CATEGORICAL VALUES INTO ACTUAL CEILING HEIGHT IN C HUNDREDS OF FT IN FD2( ). IT IS EXPECTED THAT THE INCOMING C "CONST" WILL BE 1.0 AND THAT "NSCAL" WILL BE ZERO C SO THAT THE OUTPUT WILL BE IN HUNDREDS OF FT. C 125 DO 160 K=1,NSTA TEST(K)=XDATA(K) C TEST( ) PRESERVES THE CATEGORY FORECASTS BEFORE SCALING. C IF(XDATA(K).GT.9998.5)THEN FD2(K)=XDATA(K) GO TO 160 ENDIF C J=XDATA(K) C ALL NON MISSING VALUES ARE 1 THROUGH 8 CATEGORIES. C THIS TRUNCATES TO THE CATEGORY NUMBER J. A VALUE OF C 2.0 TO 2.99 SHOULD GO INTO CATEGORY 2. THESE VALUES C COME FROM SCLCIG AND HAVE NOT BEEN PACKED. NINT C SHOULD NOT BE USED. C D WRITE(KFILDO,129)K,J,XDATA(K) D129 FORMAT(' AT 129--K,J,XDATA(K)',2I6,F30.4) IF(J.GT.NCAT)THEN WRITE(KFILDO,130)XDATA(K),NCAT,K 130 FORMAT(/' ****INCOMING CATEGORICAL DATUM =',F20.10, 1 ' IS OUTSIDE RANGE 1 TO ',I4,' IN CIGMBO', 2 ' FOR STATION NO.',I6,'. THIS IS AN ERROR AND', 3 ' ITS CAUSE SHOULD BE FOUND.') C NOTE THAT A PACKING ERROR WILL NOT CAUSE THIS ERROR C AT THE HIGH END. ISTOP(1)=ISTOP(1)+1 XDATA(K)=NCAT+.99 C MAKE THE CATEGORY THE TOP OF NOCAT. FD2(K)=9999. C FOR ANY CATEGORICAL VALUE GT NOCAT, CANNOT USE C TABLE( , ) BECAUSE J WOULD BE OUTSIDE IT. THIS C WOULD BE AN ERROR; J SHOULD NOT EXCEED NOCAT. C SAFETY FEATURE. C ELSEIF(J.LT.1)THEN WRITE(KFILDO,130)XDATA(K),NCAT,K XDATA(K)=1.01 C MAKE THE CATEGORY THE BOTTOM OF 1. FD2(K)=0. C ELSEIF(J.LT.NCAT)THEN R=TABLE(2,J)-TABLE(1,J) C D WRITE(KFILDO,135)J,TABLE(1,J),TABLE(2,J),XDATA(K),R D135 FORMAT(' AT 135 IN CIGMBO--J,TABLE(1,J),TABLE(2,J),', D 1 'XDATA(K),R',I4,4F410.3) C FD2(K)=(XDATA(K)-J)*R+TABLE(1,J) C c SCALING MAY PRODUCE VALUES BARELY OUTSIDE THE DESIRED C RANGE. THIS CHECK IS MADE IN CASE A SCALED VALUE IS C JUST OUTSIDE THE CATEGORY WHEN IT SHOULD BE IN. THE C ERROR AT 139 SHOULD NOT OCCUR. C IF(J.EQ.1)THEN C IF(FD2(K).GE.1.99)THEN FD2(K)=1.99 D WRITE(KFILDO,137)K,J,FD2(K) D137 FORMAT(/' FD2(K) MODIFIED IN CIGMBO AT 137--', D 1 'K, J, FD2(K) =',2I6,F10.4) ENDIF C ELSEIF(J.EQ.2)THEN C IF(FD2(K).LT.2.)THEN FD2(K)=2.01 D WRITE(KFILDO,137)K,J,FD2(K) ELSEIF(FD2(K).GT.4.)THEN FD2(K)=4.01 D WRITE(KFILDO,137)K,J,FD2(K) ENDIF C ELSEIF(J.EQ.3)THEN C IF(FD2(K).LT.5.)THEN FD2(K)=5.01 D WRITE(KFILDO,137)K,J,FD2(K) ELSEIF(FD2(K).GT.9.)THEN FD2(K)=9.01 D WRITE(KFILDO,137)K,J,FD2(K) ENDIF C ELSEIF(J.EQ.4)THEN C IF(FD2(K).LT.10.)THEN FD2(K)=10.01 D WRITE(KFILDO,137)K,J,FD2(K) ELSEIF(FD2(K).GT.19.)THEN FD2(K)=19.01 D WRITE(KFILDO,137)K,J,FD2(K) ENDIF C ELSEIF(J.EQ.5)THEN C IF(FD2(K).LT.20.)THEN FD2(K)=20.01 D WRITE(KFILDO,137)K,J,FD2(K) ELSEIF(FD2(K).GT.30.)THEN FD2(K)=30.01 D WRITE(KFILDO,137)K,J,FD2(K) ENDIF C ELSEIF(J.EQ.6)THEN C IF(FD2(K).LT.30.)THEN FD2(K)=31.01 D WRITE(KFILDO,137)K,J,FD2(K) ELSEIF(FD2(K).GT.65.)THEN FD2(K)=65.01 D WRITE(KFILDO,137)K,J,FD2(K) ENDIF C ELSEIF(J.EQ.7)THEN C IF(FD2(K).LT.66.)THEN FD2(K)=66.01 D WRITE(KFILDO,137)K,J,FD2(K) ELSEIF(FD2(K).GT.120.)THEN FD2(K)=120.01 D WRITE(KFILDO,137)K,J,FD2(K) ENDIF C ELSE WRITE(KFILDO,139)K,J,FD2(K) 139 FORMAT(/' ****ERROR AT 139 IN CIGMBO, K, J, FD2(K) =', 1 2I6,F10.4) ISTOP(1)=ISTOP(1)+1 ENDIF C ELSE FD2(K)=X888 C THE LAST CATEGORY MEANING PRIMARILY UNLIMITED AND C UNDETERMINED IS NOT SPREAD. SET TO X888 FOR WRITING C TO INTERNAL STORAGE FOR USE IN SCLSKY/SKYMBO. LATER C SET TO CAP. C ENDIF C 160 CONTINUE C D WRITE(KFILDO,165)(K,XDATA(K),FD2(K),K=1,NSTA) D165 FORMAT(' AT 165 IN CIGMBO--(K,XDATA(K),FD2(K),K=1,NSTA)',/ D 1 (I6,2F10.2)) C C AT THIS POINT, FD2( ) HOLDS THE FORECASTS IN HUNDREDS OF FT, C SCALED WITHIN CATEGORIES WITH THE PROBABILITIES. VALUES C IN CATEGORY NCAT HAVE VALUES 888. C C MODIFY BY OBSERVATIONS IF DESIRED. C IF(IDPARS(12).LT.IBEND)THEN C C RETRIEVE THE OBS. THE ID COMES FROM THE U405A.CN C FILE, ENTRY 7. C CALL GFETCH(KFILDO,KFIL10,IDOBS,7777,LSTORE,ND9,LITEMS, 1 IS0,IS1,IS2,IS4,ND7,IPACK,IWORK,FD3,NSTA, 2 NWORDS,NPACK,NDATE,NTIMES,CORE,ND10, 3 NBLOCK,NFETCH,NSLAB,MISSP,MISSS,L3264B,1,IER) C IF(IER.NE.0)THEN ISTOP(3)=ISTOP(3)+1 WRITE(KFILDO,170)(LD(M1),M1=1,4) 170 FORMAT(/' ****COULD NOT FIND CEILING HEIGHT OBS', 1 3I10.9,I10,'. CONTINUING WITHOUT OBS', 2 ' MODIFICATION.') C C WHEN OBS NOT AVAILABLE, PRESERVE SCALED FORECASTS C IN FD2( ) TO XDATA( ) AND SKIP OBS INSERTION. C DO 173 K=1,NSTA XDATA(K)=FD2(K) C VALUES OF 888 PRESENT. 173 CONTINUE C GO TO 200 ENDIF C ELSE C DO 175 K=1,NSTA XDATA(K)=FD2(K) C VALUES OF 888 PRESENT. 175 CONTINUE C GO TO 200 C USE OF OBS FOR THIS PROJECTION NOT USED. ENDIF C D WRITE(KFILDO,176)(FD3(K),K=1,NSTA) D176 FORMAT(/,' IN CIGMBO AT 176--FD3(K)',/,(15F8.2)) C IF(IBEND.NE.IBSTRT)THEN RANGE=IBEND-IBSTRT R=(IDPARS(12)-IBSTRT)/RANGE ELSE R=1 C THIS R SHOULD NOT BE NEEDED. DEFINED FOR SAFETY. ENDIF C WRITE(KFILDO,177)IDPARS(12) 177 FORMAT(' CEILING HEIGHT BEING ADJUSTED BY OBS AT', 1 ' PROJECTION =',I4) C DO 180 K=1,NSTA XDATA(K)=FD2(K) C IF(FD3(K).GT.9998.5.OR.XDATA(K).GT.9998.5)THEN C WHEN EITHER THE OB OR FORECAST IS MISSING, NO C INSERTION IS DONE. GO TO 180 ENDIF C J=TEST(K) C THIS TRUNCATES THE ORIGINAL CATEGORICAL FORECAST TO THE C CATEGORY NUMBER J. A VALUE OF 2.0 TO 4.001 SHOULD GO C INTO CATEGORY 2. C D WRITE(KFILDO,178)K,RANGE,R,J,XDATA(K),FD3(K), D 1 TABLE(1,J),TABLE(2,J),IDPARS(12) D178 FORMAT(/' AT 178--K,RANGE,R,J,XDATA(K),FD3(K),', D 1 'TABLE(1,J),TABLE(2,J),IDPARS(12)', D 2 I4,2F8.2,I3,4F6.2,I3) C C AT THIS POINT, BOTH OB AND FORECAST ARE GOOD. BOTH C MAY CONTAIN 888 AND OBS ARE NOT CAPPED. C IF(J.LT.NCAT)THEN C IF(FD3(K).GE.TABLE(1,J).AND.FD3(K).LE.TABLE(2,J))THEN C THE OB IS IN THE FORECAST RANGE. CHANGED LT C TO LE 9/3/15. C CCCC IF(J.EQ.1.OR.J.EQ.2)THEN CCCC WRITE(KFILDO,1785)FD3(K),J,K,TABLE(1,J),TABLE(2,J), CCCC 1 XDATA(K),TEST(K) CCCC 1785 FORMAT(/' ADDING OB =',F5.1,' IN CATEGORY',I3, CCCC 1 ' STATION NO.',I6,' BETWEEN LIMITS', 2F7.3, CCCC 2 ', ORIGINAL VALUE =',F7.3, CCCC 3 ', ORIGINAL SCALED VALUE',F7.3)) CCCC ENDIF C IF(IDPARS(12).LE.IBSTRT)THEN C THE OB IS IN THE FORECAST RANGE. C USE THE OB AT AND BEFORE PROJECTION IBSTRT. XDATA(K)=FD3(K) ELSEIF(IDPARS(12).LT.IBEND)THEN C THE OB IS IN THE FORECAST RANGE, SO WEIGHT C AVERAGE THE FORECAST AND THE OB, SUCH THAT C AT THE LOW END, THE OB IS USED, AND AT THE C HIGH END, THE FORECAST IS USED. XDATA(K)=R*FD2(K)+(1.-R)*FD3(K) ELSE C THE PROJECTION IS OUTSIDE THE IBSTART-IBEND RANGE. C USE THE FORECAST. XDATA( ) HAS ALREADY BEEN C SET TO FD2( ). NO ACTION NEEDED. ENDIF C ELSE C THE OB IS NOT IN THE FORECAST RANGE, SO USE THE C FORECAST. XDATA( ) HAS ALREADY BEEN SET TO FD2( ). C NO ACTION NEEDED. ENDIF C ELSE C THIS IS FOR CATEGORY NCAT. ONLY COMES HERE WHEN C IDPARS(12).LT.IBEND. C IF(FD3(K).GE.TABLE(1,J))THEN C TREAT THE UPPER CATEGORY AS OPEN ENDED. C IF(IDPARS(12).LE.IBSTRT)THEN C IF(FD3(K).GT.887.9)THEN C THE INCOMING OBSERVATION WILL BE 888 FOR C UNLIMITED. LEAVE IT AT THAT FOR NOW. XDATA(K)=X888 ELSE XDATA(K)=FD3(K) C DATA WERE PACKED, SO EXACT OBS (E.G., 120) MAY C NOT BE EXACTLY 120. PRESERVE THE OB, ALTHOUGH C IT WILL BE PACKED ON OUTPUT AND MAY NOT THEN C BE EXACT. AN OBSERVATION IS UNLIMITED IF C EQUAL TO 888. IT IS LATER SET TO CAP. ENDIF C ELSE XDATA(K)=X888 C THERE IS NO TEMPORAL INTERPOLATION FOR C CATEGORY 8. WHEN THE PROJECTION IS > IBSTRT C AND < IBEND, IT IS JUST SET TO X888 FOR NOW. ENDIF C ELSE C THIS IS FOR CATEGORY NCAT = 8 WHEN THE OB IS NOT C IN THAT CATEGORY (>120). NO ACTION NECESSARY. ENDIF C ENDIF C D WRITE(KFILDO,179)K,XDATA(K),FD2(K),FD3(K) D179 FORMAT(' AT 179--K,XDATA(K),FD2(K),FD3(K)',I6,3F8.2) C 180 CONTINUE C 200 CONTINUE C C WRITE THE FORECAST CEILING HEIGHTS WITH UNLIMITED = X888 = C 888 FOR USE IN SCLSKY/SKYMBO TO INTERNAL STORAGE. C LD(1)=ID(1)+2000 C THE DATA WITH 888 WILL HAVE CCCFFF = 208073000. LD(2)=ID(2) LD(3)=ID(3) LD(4)=ID(4) CALL GSTORE(KFILDO,KFIL10,LD,0,LSTORE,ND9,LITEMS, 1 XDATA,NSTA,1,0,NDATE, 2 CORE,ND10,LASTL,NBLOCK,LASTD,NSTORE,L3264B,IER) C "NSLAB" IS STORED AS ZERO SIGNIFYING THE DATA ARE NOT C PACKED AND CAN BE TREATED AS VECTOR DATA. C IF(IER.EQ.0)THEN C IF(IP16.NE.0)THEN WRITE(IP16,214)(LD(JJ),JJ=1,4),PLANT,NDATE 214 FORMAT(/' WRITING DATA TO UNIT KFIL10',3I10.9,I10.3,3X, 1 A32,' FOR DATE',I12) ENDIF C ELSE ISTOP(1)=ISTOP(1)+1 WRITE(KFILDO,215)(LD(JJ),JJ=1,4) 215 FORMAT(' ERROR WRITING VARIABLE',3(1X,I9.9),1X,I10.3, 1 ' TO INTERNAL STORAGE.',/, 2 ' SOME COMPUTATIONS (PRE- OR POST-PROCESSING)', 3 ' MAY NOT BE ABLE TO BE MADE. PROCEEDING.') ENDIF C C CAP ALL FORECASTS, INCLUDING 888, TO CAP. C DO 216 K=1,NSTA C IF(XDATA(K).LT.9998.5)THEN XDATA(K)=MIN(XDATA(K),CAP) ENDIF C 216 CONTINUE C C COMPUTE THE FREQUENCIES. THE TEST IS ON LE, SO THE LISTED C VALUE IS THE HIGH END OF THE CATEGORY, INCLUSIVELY. C DO 217 J=1,16 IFREQ(J)=0 217 CONTINUE C TOTAL=0. C DO 220 K=1,NSTA DO 218 J=1,16 C IF(XDATA(K).LE.FREQ(J))THEN IFREQ(J)=IFREQ(J)+1 GO TO 219 ENDIF C 218 CONTINUE C GO TO 220 C OTHERWISE, MISSINGS WOULD BE COUNTED. C 219 TOTAL=TOTAL+1 220 CONTINUE C IF(TOTAL.EQ.0.)THEN WRITE(KFILDO,225) 225 FORMAT(/' ERROR IN CIGMBO. TOTAL = 0.') ISTOP(1)=ISTOP(1)+1 GO TO 240 ENDIF C DO 230 J=1,16 RFREQ(J)=IFREQ(J)/TOTAL 230 CONTINUE C WRITE(KFILDO,232)(FREQ(J),J=1,16) 232 FORMAT(/' LE HDS FT ',16F7.2,' TOTAL') WRITE(KFILDO,233)(IFREQ(J),J=1,16),NINT(TOTAL) 233 FORMAT(' FREQUENCIES',16I7,I9) WRITE(KFILDO,234)(RFREQ(J),J=1,16) 234 FORMAT(' REL FREQ ',16F7.2) C C SCALING NECESSARY ONLY WHEN CONST NE 1 OR NSCAL NE 0. C THIS IS ONLY FOR OUTPUT; ALL COMPUTATIONS MADE IN HUNDREDS C OF FEET. LIKELY NO SCALING IS TO BE DONE. C IF(CONST.NE.1.OR.NSCAL.NE.0)THEN C FACTOR=CONST*10.**NSCAL C WRITE(KFILDO,237)FACTOR 237 FORMAT(/' SCALING FACTOR =',E12.5,' IS BEING USED IN CIGMBO.'/ 1 ' THIS IS UNUSUAL; IS IT CORRECT?') C DO 238 K=1,NSTA C IF(XDATA(K).LT.9998.5)THEN XDATA(K)=XDATA(K)*FACTOR ENDIF C 238 CONTINUE C ENDIF C 240 RETURN END