SUBROUTINE BOGUSG(KFILDO,KFIL10,ID,IDPARS,JD,NDATE, 1 CCALL,XP,YP,LNDSEA,QUALST,NAREA, 2 XDATA,LTAG,LTAGPT,VRAD,ELEV,NSTA,ND1, 3 P,NX,NY,SEALND,TELEV,NXE,NYE,MESHE,NPROJ, 4 NCAT,NSCALE,CONST,IPREX1, 5 IPREX2,PREX3,PREX4,GUESS, 6 IS0,IS1,IS2,IS4,ND7, 7 LSTORE,ND9,LITEMS,IPACK,IWORK,ND5, 8 CORE,ND10,NBLOCK, 9 L3264B,ISTOP,IER) C C NOVEMBER 2018 GLAHN TDL MOS-2000 C REVISED FROM BOGUS C DECEMBER 2018 GLAHN CHANGED THIS TYPE BOGUS TO 4 C DECEMBER 2018 GLAHN SWITCHED ELEMENTS IN CALL C FEBRUARY 2019 GLAHN ADDED PREX4 AND GUESS TO CALL C FEBRUARY 2019 GLAHN ADDED VRAD TO CALL C FEBRUARY 2019 GLAHN ADDED DIAGNOSTICS C FEBRUARY 2019 GLAHN CHANGED VRAD(NSTA,6) TO VRAD(ND1,6) C FEBRUARY 2019 GLAHN ADDED ELEV( ) AND TELEV( , ) C TO CALL; DEFINED ELEV( ) C FEBRUARY 2019 GLAHN ADDED NAREA TO CALL C JANUARY 2020 GLAHN ADDED DIAGNOSTIC 261 C C PURPOSE C TO PROVIDE DATA FOR ANALYSIS AT GRIDPOINTS FROM A C FIRST GUESS FIELD. GENERALLY, WATER IS GIVEN VALUES C FROM THE FIRST GUESS GRID AND LAND IS GIVEN THE VALUE C GUESS. THIS CAN BE USED AFTER BOGUS OR WITHOUT IT. C C BOGUSG IS CALLED FOR EACH RUN (WITH RUN AVERAGING). THE C INTERPOLATION IN EACH CALL WILL BE THE SAME (DUPLICATE C ITSELF), BUT THE AVERAGING WILL GIVE DIFFERENT RESULTS. C C THE BOGUS 'CALL LETTERS' WILL BE OF THE FORM XXXXYYYY C WHERE XXXX IS THE IX GRIDPOINT POSITION AND YYYY IS THE C JY GRIDPOINT POSITION. 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/OUTPUT) C C VARIABLES C KFILDO = UNIT NUMBER FOR OUTPUT (PRINT) FILE. (INPUT) C KFIL10 = UNIT NUMBER FOR INTERNAL RANDOM ACCESS STORAGE. C (INPUT) C ID(J) = 4-WORD ID OF VARIABLE TO PROVIDE DATA FOR 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 (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 NOT ACTUALLY USED. (INPUT) C NDATE = THE DATE/TIME OF THE RUN. (INPUT) C CCALL(K) = CALL LETTERS OF STATIONS (J=1,NSTA). C (INPUT/OUTPUT) C XP(K) = THE X POSITION FOR STATION K (K=1,NSTA) ON C THE ANALYSIS GRID AREA AT THE CURRENT GRID MESH C LENGTH XMESH. (INPUT/OUTPUT) C YP(K) = THE Y POSITION FOR STATION K (K=1,NSTA) ON C THE ANALYSIS GRID AREA AT THE CURRENT GRID MESH C LENGTH XMESH. (INPUT/OUTPUT) C LNDSEA(K) = LAND/SEA INFLUENCE FLAG FOR EACH STATION C (K=1,ND1). C 0 = WILL BE USED FOR ONLY OCEAN WATER (=0) C GRIDPOINTS. C 3 = WILL BE USED FOR ONLY INLAND WATER (=3) C GRIDPOINTS. C 6 = WILL BE USED FOR BOTH INLAND WATER (=3) C AND LAND (=9) GRIDPOINTS. C 9 = WILL BE USED FOR ONLY LAND (=9) GRIDPOINTS. C (INPUT/OUTPUT) C QUALST(K) = THE QUALITY WEIGHTS TO APPLY FOR THIS VARIABLE C (K=1,KSTA). AUGMT2 MODIFYS THEM. (INTERNAL) C XDATA(K) = DATA VALUES (K=1,NSTA). (INPUT/OUTPUT) C LTAG(J) = DENOTES USE OF DATA CORRESPONDING TO CCALL(J). C +4 = TOSSED IN A PREVIOUS OBS RUN AND C MAINTAINED DOWNSTREAM. C +3 = TOSSED IN A PREVIOUS LAMP RUN, AND C MAINTAINED DOWNSTREAM. C +2 = NOT USED FOR ANY PURPOSE. C +1 = PERMANENTLY DISCARDED FOR THE VARIABLE C BEING ANALYZED. INCLUDES DATA FAR C OUTSIDE THE GRID, AS DEFINED BY RMAX C 0 = USE ON CURRENT PASS THROUGH DATA. C -1 = DO NOT USE ON THIS PASS. C -3 = ACCEPT THIS STATION ON EVERY PASS. THIS C FEATURE MAY OR MAY NOT BE IMPLEMENTED IN C THE CALLING PROGRAM. (INPUT/OUTPUT) C LTAGPT(K) = FOR STATION K (K=1NSTA), C 1 = AUGMENTED DATA (FIRST PASS) C 2 = AUGMENTED DATA (2ND OR LATER PASS) C 3 = BOGUS DATA FROM BOGUS c 4 = BOGUS DATA FROM BOGUSG C 0 = EVERYTHING ELSE C (INPUT/OUTPUT) C VRAD(K,L) = RADII OF INFLUENCE USED AS OVERRIDE TO U405.CN C CONTROL FILE (K=1,ND1) (L=1,6). NOTE THAT C THIS APPLIES TO THE INDIVIDUAL ELEMENT; ITS C USE IS CONTROLLED BY IVRAD. (INPUT/OUTPUT) C ELEV(K) = STATION ELEVATIONS (K=1,NSTA) (INPUT/OUTPUT) C NSTA = NUMBER OF STATIONS BEING USED; THE NUMBER C OF VALUES IN CCALL( ) AND XDATA( ). C (INPUT/OUTPUT) C ND1 = DIMENSION OF CCALL( ) C P(I,J) = THE FIRST GUESS FROM FSTGS5 (I=1,NX) (J=1,NY). C (INPUT) C NX = THE X-EXTENT OF THE GRID P( , ). (INPUT) C NY = THE Y-EXTENT OF THE GRID P( , ). (INPUT) C SEALND(IX,JY) = THE LAND/SEA MASK (IX=1,NXE), J=1,NXE*NYE). C 0 = OCEAN WATER GRIDPOINTS; C 3 = INLAND WATER GRIDPOINTS. C 9 = LAND GRIDPOINTS. C (INPUT) C TELEV(IX,JY) = THE TERRAIN ELEVATION FROM THE MOS-2000 EXTERNAL C RANDOM ACCESS FILE IN METERS (IX=1,NXE) C (JY=1,NYE). (INPUT) C NXE = X-EXTENT OF SEALND( ) AT MESH LENGTH MESHE. C (INPUT) C NYE = Y-EXTENT OF SEALND( ) AT MESH LENGTH MESHE. C (INPUT) C MESHE = THE NOMINAL MESH LENGTH OF THE SEALND* , ) GRID. C (INPUT) C NPROJ = NUMBER OF MAP PROJECTION TO WHICH THIS GRID C APPLIES. C 3 = LAMBERT. C 5 = POLAR STEREOGRAPHIC. C 7 = MERCATOR. C (INPUT) C NCAT = 1 = OCEAN GRIDPOINT GIVEN VALUE. C 2 = OCEAN GRIDPOINT OUTSIDE SURF ZONE GIVEN VALUE C (NOT CHECKED OUT). C 0 = NO VALUE FOR OCEAN GRIDPOINT. C (INPUT) C NSCALE = DETERMINES DENSITY OF POINTS: C 0 = INOPERATIVE C 1 = EVERY POINT. C 2 = EVERY 2ND POINT, C 3 = EVERY 3RE POINT, ETC. C (INPUT) C CONST = FRACTIONAL WEIGHT TO GIVE TO THESE POINTS C (MAY BE HARDWIRED TO VARY BY PASS. C 0 = INOPERATIVE C (INPUT) C IPREX1 = 1 = LAKE GRIDPOINT GIVEN VALUE. C 2 = LAKE GRIDPOINT OUTSIDE SURF ZONE GIVEN VALUE. C 0 = NO VALUE FOR LAKE GRIDPOINT. C (INPUT) C IPREX2 = 1 = LAND GRIDPOINT GIVEN VALUE. C 2 = LAND/RUSSIA GIVEN VALUE. THIS IS BASED ON C HARDWIRED GRIDPOINTS BASED ON NBM GRID C AT 3-KM C 0 = NO VALUE FOR LAND GRIDPOINT. C (INPUT) C PREX3 = RADIUS TO USE, IN TERMS OF GRID SPACINGS. C (MAY BE HARDWIRED TO VARY BY PASS.) C (INPUT) C PREX4 = = 1. WHEN LAND POINTS EXCEPT SIBERIA ARE C GO BE SET TO GUESS. THIS COULD NOT BE DONE C IN FSTGS5 BECAUSE THE MODEL FIELD WAS NEEDED C HERE. C = 0. OTHERWISE. C (INPUT) C GUESS = THE GUESS VALUE FOR LAND EXCEPT SIBERIA C WHEN PREX4. = 1. (INPUT) C IS0(J) = MOS-2000 GRIB SECTION 0 ID'S (J=1,4). C (INTERNAL) C IS1(J) = MOS-2000 GRIB SECTION 1 ID'S (J=1,21+). C (INTERNAL) C IS2(J) = MOS-2000 GRIB SECTION 2 ID'S (J=1,12). C (INTERNAL) C IS4(J) = MOS-2000 GRIB SECTION 4 ID'S (J=1,4). C (INTERNAL) C ND7 = DIMENSION OF IS0( ), IS1( ), IS2( ), AND C IS4( ). (INPUT) C IPACK(J) = WORK ARRAY (J=1,ND5). (INTERNAL) C IWORK(J) = WORK ARRAY (J=1,ND5). (INTERNAL) C ND5 = DIMENSION OF IPACK( ), IWORK( ), AND DATA( ). C (INPUT) C NBLOCK = BLOCK SIZE IN WORDS OF INTERNAL MOS-2000 DISK C STORAGE. (INPUT) 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 EACH TIME A FATAL C ERROR OCCURS. C ISTOP(5)--IS INCREMENTED IN ITRPSL WHEN NO C NON-MISSING GRIDPOINT AROUND THE C DATA POINT IS OF THE SAME TYPE. C ISTOP(6)--IS INCREMENTED WHEN THERE IS A PROBLEM C WITH MAKING BOGUS STATIONS. C (INPUT/OUTPUT) C IER = ERROR CODE. C 0 = GOOD RETURN. C 103 = COULD NOT IDENTIFY ID IN INTERNAL TABLE. C 777 = WHEN A CALLED ROUTINE DID NOT FURNISH C AN IER. C OTHER VALUES FROM CALLED ROUTNES. EVERY C ERROR IS FATAL FOR THIS ELEMENT. C (OUTPUT) C FD2(IX,JY) = WORK ARRAY. (INTERNAL) (AUTOMATIC) C 1 2 3 4 5 6 7 X C C NONSYSTEM SUBROUTINES CALLED C NONE C CHARACTER*6 STATE CHARACTER*8 CCALL(ND1) C DIMENSION ID(4),IDPARS(15),JD(4) DIMENSION XP(ND1),YP(ND1),LNDSEA(ND1),XDATA(ND1),LTAGPT(ND1), 1 LTAG(ND1),QUALST(ND1),ELEV(ND1) DIMENSION VRAD(ND1,6) DIMENSION P(NX,NY) DIMENSION FD2(NX,NY) C FD2( , ) IS AN AUTOMATIC ARRAY. DIMENSION SEALND(NXE,NYE),TELEV(NXE,NYE) DIMENSION IPACK(ND5),DATA(ND5),IWORK(ND5) DIMENSION IS0(ND7),IS1(ND7),IS2(ND7),IS4(ND7) DIMENSION LSTORE(12,ND9) DIMENSION CORE(ND10) DIMENSION ISTOP(6) DIMENSION ITABLE(7,2),LD(4) C DATA ITABLE/80, 40, 20, 10, 5, 3, 1, 1 0, 1, 2, 3, 4, 5, 6/ C IER=0 CALL TIMPR(KFILDO,KFILDO,'START BOGUSG ') C D WRITE(KFILDO,100)NSTA,ND1,NX,NY,GUESS D100 FORMAT(/' IN BOGUSG AT 100--NSTA,ND1,NX,NY,GUESS',4I10,F8.4) WRITE(KFILDO,101)NCAT,NSCALE,CONST,IPREX1,IPREX2,PREX3,PREX4 101 FORMAT(/' IN BOGUSG--', 1 'NCAT,NSCALE,CONST,IPREX1,IPREX2,PREX3,PREX4,JFULF', 2 2I6,F8.2,2I6,2F8.2,I8) C C MAKE SURE DIMENSIONS AGREE. C IF(NX.NE.NXE.OR.NY.NE.NYE)THEN WRITE(KFILDO,110)NX,NY,NXE,NYE 110 FORMAT(/' ****NX AND NY = ',2I6, 1 ' DO NOT AGREE WITH NXE AND NYE =',2I6, 2 '. STOP IN BOGUSG AT 110.') ISTOP=ISTOP+1 IER=777 STOP 110 ENDIF C C FIND WHETHER THE ARRAY SEALND( , ) TO BE USED. C IF(NCAT.EQ.1.OR.IPREX1.EQ.1.OR.IPREX2.EQ.1)THEN C DO 150 IX=1,NX DO 149 JY=1,NY C INDEX THIS WAY TO MAKE THE IDS ORDERED LOW TO HIGH. C IF((NINT(SEALND(IX,JY)).EQ.0.AND.NCAT.EQ.1).OR. C ABOVE GETS OCEAN. 1 (NINT(SEALND(IX,JY)).EQ.3.AND.IPREX1.EQ.1).OR. C ABOVE GETS LAKES (THERE ARE NONE IN ALASKA). 2 (NINT(SEALND(IX,JY)).GT.3.AND.IPREX2.EQ.1).OR. C ABOVE GETS ALL LAND. 3 (NINT(SEALND(IX,JY)).GT.3.AND.IPREX2.EQ.2.AND. 4 NAREA.EQ.2.AND.IX.LT.610.AND.JY.GT.756))THEN C ABOVE GETS RUSSIA LAND ON ALASKA GRID, BASED C ON NBM GRID AT 3-KM. NSTA=NSTA+1 C IF(NSTA.LE.ND1)THEN WRITE(UNIT=CCALL(NSTA),FMT='(2I4.4)')IX,JY XP(NSTA)=IX YP(NSTA)=JY LNDSEA(NSTA)=NINT(SEALND(IX,JY)) XDATA(NSTA)=P(IX,JY) LTAGPT(NSTA)=4 C SET LTAGPT( ) TO "BOGUS" = 4. LTAG(NSTA)=0 QUALST(NSTA)=1. ELEV(NSTA)=TELEV(IX,JY) C DO 117 L=1,6 VRAD(NSTA,L)=PREX3 117 CONTINUE C D IF(JY.EQ.700)THEN D WRITE(KFILDO,119)NSTA,CCALL(NSTA),XDATA(NSTA), D 1 NCAT,IPREX1,IPREX2,PREX3,PREX4 D119 FORMAT(' IN BOGUSG AT 119--', D 1 'NSTA,CCALL(NSTA),XDATA(NSTA)', D 2 'NCAT,IPREX1,IPREX2,PREX3,PREX4', D 3 I8,2X,A8,F8.2,3I4,3F8.2) D ENDIF C D IF(NINT(SEALND(IX,JY)).EQ.3)THEN D WRITE(KFILDO,1190)NSTA,CCALL(NSTA),XDATA(NSTA), D 1 NCAT,IPREX1,IPREX2,PREX3,PREX4 D1190 FORMAT(' IN BOGUS AT 1190--', D 1 'NSTA,CCALL(NSTA),XDATA(NSTA)', D 2 'NCAT,IPREX1,IPREX2,PREX3,PREX4', D 3 I8,2X,A8,F8.2,3I4,3F8.2) D ENDIF C ELSE WRITE(KFILDO,120)ND1 120 FORMAT(/' ****ND1 =',I10,' ABOUT TO BE EXCEEDED IN', 1 ' BOGUSG. STOP IN BOGUSG AT 120.') STOP 120 ENDIF C ENDIF C 149 CONTINUE 150 CONTINUE C ENDIF C FIND WHETHER THE DISTANCE TO LAND ARRAY IS TO BE USED. C IF(NCAT.EQ.2.OR.IPREX1.EQ.2)THEN C C READ THE DISTANCE TO SHORE GRID FROM THE INTERNAL RANDOM C ACCESS FILE INTO FD2( , ). C DO 210 J=1,7 C IF(MESHE.EQ.ITABLE(J,1))THEN LD(1)=409003000+NPROJ*100000+ITABLE(J,2)*10000 LD(2)=0 LD(3)=0 LD(4)=0 GO TO 212 ENDIF C 210 CONTINUE C C FALL THROUGH HERE MEANS THE NOMINAL GRID LENGTH MESHE C IS NOT ONE OF THE VALUES HANDLED IN ITABLE( , ). C WRITE(KFILDO,211) 211 FORMAT(/' ****MESH LENGTH FOR CONSTANT GRID FROM GTHRES IS', 1 ' NOT HANDLED IN ITABLE( , ) IN BOGUSG.', 2 ' STOP IN BOGUSG AT 211.') ISTOP=ISTOP+1 IER=777 STOP 211 C 212 CALL GFETCH(KFILDO,KFIL10,LD,7777,LSTORE,ND9,LITEMS, 1 IS0,IS1,IS2,IS4,ND7,IPACK,IWORK,FD2,NX*NY, 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,214)(LD(M1),M1=1,4) 214 FORMAT(/' ****COULD NOT FIND DISTANCE GRID', 1 3I10.9,I10,'. STOP IN BOGUSG AT 214.') IER=777 STOP 214 ENDIF C DO 250 IX=1,NX DO 249 JY=1,NY C IF((FD2(IX,JY).EQ.0..AND.NCAT.EQ.2).OR. 1 (FD2(IX,JY).EQ.3..AND.IPREX1.EQ.2).OR. 2 (FD2(IX,JY).GT.3..AND.IPREX2.EQ.2))THEN NSTA=NSTA+1 C IF(NSTA.LE.ND1)THEN WRITE(UNIT=CCALL(NSTA),FMT='(2I4.4)')IX,JY XP(NSTA)=IX YP(NSTA)=JY LNDSEA(NSTA)=NINT(SEALND(IX,JY)) XDATA(NSTA)=P(IX,JY) LTAGPT(NSTA)=4 C SET LTABPT( ) TO "BOGUS" = 4. LTAG(NSTA)=0 QUALST(NSTA)=1. ELSE WRITE(KFILDO,220)ND1 220 FORMAT(/' ****ND1 =',I10,' ABOUT TO BE EXCEEDED IN', 1 ' BOGUSG. STOP IN BOGUSG AT 220.') STOP 220 ENDIF C ENDIF C 249 CONTINUE 250 CONTINUE C ENDIF C C WHEN PREX4 = 1., SET ALL LAND GRIDPOINTS TO GUESS. c THIS HAS TO BE DONE AFTER BOGUSING BECAUSE BOGUS POINTS c ARE TO COME FROM THE MODEL NOT A CONSTANT. C IF(NINT(PREX4).EQ.1)THEN C IF(NAREA.EQ.2)THEN WRITE(KFILDO,260)GUESS 260 FORMAT(' BOGUSG SETS ALL GRIDPOINTS TO GUESS =',F7.2, 1 '. WATER AND SIBERIA HAVE "STATIONS" AT', 2 ' GRIDPOINTS SET TO FIRST GUESS.') ELSE WRITE(KFILDO,261)GUESS 261 FORMAT(' BOGUSG SETS ALL GRIDPOINTS TO GUESS =',F7.2, 1 '. WATER HAS "STATIONS" AT', 2 ' GRIDPOINTS SET TO FIRST GUESS.') ENDIF C DO 270 JY=1,NY DO 269 IX=1,NX c ALL GRIDPOINTS CAN BE SET TO GUESS BECAUSE WATER C AND SIBERIA HAVE "STATIONS" AT GRIDPOINTS. P(IX,JY)=GUESS 269 CONTINUE 270 CONTINUE C ENDIF C CALL TIMPR(KFILDO,KFILDO,'END BOGUSG ') RETURN END