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 FEBRYART 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
C PURPOSE
C TO PROVIDE DATA FOR ANALYSIS AT GRIDPOINTS FROM A
C FIRST GUESS FIELD. THIS CAN BE USED AFTER BOGUS OR
C WITHOUT IT.
C
C BOGUS 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 FALUE.
C 0 = NO VALUE FOR OCEAN GRIDPOINT.
C (INPUT)
C NSCALE = DETERMINES DENSITY OF POINTS:
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 (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
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 ')
D WRITE(KFILDO,100)NSTA,ND1,NX,NY,GUESS
D100 FORMAT(/' IN BOGUSG AT 100--NSTA,ND1,NX,NY',4I10,F8.4)
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).
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 LTABPT( ) 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 BOGUS5--NSTA,CCALL(NSTA),XDATA(NSTA)',
D 1 'NCAT,IPREX1,IPREX2,PREX3,PREX4',
D 2 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 EXCEPT SIBERIA
C TO GUESS. THIS HAS TO BE DONE AFTER BOGUSING BECAUSE
C BOGUS PIONTS ARE TO COME FROM THE MODEL NOT A CONSTANT.
C
IF(NINT(PREX4).EQ.1)THEN
C
WRITE(KFILDO,260)GUESS
260 FORMAT(' BOGUSG SETS ALL GRIDPOINS TO GUESS =',F6.0,
1 ' WATER AND SIBERIA HAVE "STATIONS" AT',
2 ' GRIDPOINTS SET TO RAP.')
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 GRIDPONTS.
C
CCCCC IF(SEALND(IX,JY).GT.8.5)THEN
C
CCCCC IF(IX.GE.610.OR.JY.LT.756)THEN
C THIS EXCLUDES SIBERIA.
P(IX,JY)=GUESS
CCCCC ENDIF
C
CCCCC ENDIF
C
269 CONTINUE
270 CONTINUE
C
ENDIF
C
CALL TIMPR(KFILDO,KFILDO,'END BOGUSG ')
RETURN
END