SUBROUTINE RAPGRDAK(KFILDO,KFIL10,ID,IDPARS,NDATE,IPACK, 1 IWORK,DATA,NSLAB,ND5,ND1,NGRID,CCALL,NSTA,DIR, 2 FD1,FD2,FD3,FD4,FD5,FD6,FDSINS,FDMS,ND2X3, 3 NGRIDC,ND11,LSTORE,ND9,LITEMS,CORE,ND10, 4 NBLOCK,NFETCH,IS0,IS1,IS2,IS4,ND7, 5 ISTAV,L3264B,L3264W,IER) C C MARCH 2018 SHAFER BASED ON ORIGINAL ROUTINE HRRRGRD. C MODIFIED FOR NEW 5KM GRID SPECS AND TO C REMOVE RENDERING TO 10KM GRID. C APRIL 2018 SHAFER ADDED ID AND PROCESSING FOR 1-H AREAL C COVERAGE >=0.01". C JANUARY 2020 CHARBA CORRECTED THE SMOOTHING CALL BELOW C LABEL 480 C FEBRUARY 2020 SAMPLATSKY CODE CONFIRMED TO BE WORKING, C SO REMOVED A LOT OF COMMENTED LOGIC C PERTAINING TO GRID RENDERING, AND C RESTRUCTURED THINGS TO REMOVE ALL C GOTO STATEMENTS. C MAY 2020 CHARBA SKIMMED CODE ...APPEARS READY FOR NCO C HAND-OFF C C PURPOSE C RENDER 3-KM HRRR FIELDS TO 5-KM NBM GRID. C C THE FOLLOWING IDPARS(1) AND IDPARS(2) ARE ACCOMMODATED. C 007 - 801 COMPOSITE REFLECTIVITY (RENDERED) C 003 - 355 PRECIP WATER (RENDERED) C 007 - 011 LIFTED INDEX (RENDERED) C 007 - 811 VERTICALLY INTEGRATED LIQUID (RENDERED) C 007 - 101 CAPE (RENDERED) C 003 - 202 1H PRECIP AMT (RENDERED) C 003 - 203 1H PRECIP AREAL COVERAGE (RENDERED) C 003 - 501 MOISTURE DIV (COMPUTED HERE) C 007 - 651 LIGHTNING THREAT (RENDERED) C C DATA SET USE C KFILDO - DEFAULT UNIT NUMBER FOR OUTPUT (PRINT) FILE C (OUTPUT). C KFIL10 - UNIT NUMBER OF TDL MOS-2000 FILE SYSTEM ACCESS C (INPUT-OUTPUT). C C VARIABLES C KFILDO = DEFAULT UNIT NUMBER FOR OUTPUT (PRINT) FILE. C (OUTPUT) C KFIL10 = UNIT NUMBER OF TDL MOS-2000 FILE SYSTEM ACCESS. C (INPUT-OUTPUT) C ID(J) = IDENTIFIERS FOR THE VARIABLE BEING COMPUTED. C IDPARS(J) = THE PARSED, INDIVIDUAL COMPONENTS OF THE C OUTPUT ID CORRESPONDING TO ID( ) (J=1,15). C (INPUT) 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 1 C 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 NDATE = THE DATE/TIME FOR OUTPUT VARIABLE. (INPUT) C IPACK(J) = WORK ARRAY (J=1,ND5). (INTERNAL) C IWORK(J) = WORK ARRAY (J=1,ND5). (INTERNAL) C DATA(K) = DATA (GRIDDED) RETURNED (K=1,NX2*NY2). NOTE: C DATA( ) IS DIMENSIONED ND5. (OUTPUT) C ND5 = DIMENSION OF IPACK( ), IWORK( ), AND C DATA( ). (INPUT) C ND2X3 = DIMENSION OF FD1( ),FD2( ), AND FD3( ). C (INTERNAL) C NSLAB = SLAB OF THE GRID IN USE...SET EQUAL TO NCHECK C (THE OUTPUT GRID) BEFORE RETURNING TO OPTION. C (OUTPUT) C LSTORE(L,J) = THE ARRAY HOLDING INFORMATION ABOUT THE DATA C STORED (L=1,12) (J=1,LITEMS). (INPUT-OUTPUT) C L=1,4--THE 4 ID'S FOR THE DATA. C L=5 --LOCATION OF STORED DATA. WHEN IN CORE, C THIS IS THE LOCATION IN CORE( ) WHERE C THE DATA START. WHEN ON DISK, C THIS IS MINUS THE RECORD NUMBER WHERE C THE DATA START. C L=6 --THE NUMBER OF 4-BYTE WORDS STORED. C L=7 --2 FOR DATA PACKED IN TDL GRIB, 1 FOR C NOT. C L=8 --THE DATE/TIME OF THE DATA IN FORMAT C YYYYMMDDHH. C L=9 --NUMBER OF TIMES DATA HAVE BEEN C RETRIEVED. C L=10 --NUMBER OF THE SLAB IN DIR( , ,L) AND C IN NGRIDC( ,L) DEFINING THE C CHARACTERISTICS OF THIS GRID. C L=11 --THE NUMBER OF THE PREDICTAND IN THE C SORTED LIST IN ID( ,N) (N=1,NPRED) C FOR WHICH THIS VARIABLE IS NEEDED, WHEN C IT IS NEEDED ONLY ONCE FROM C LSTORE( , ). WHEN IT IS NEEDED MORE C THAN ONCE, THE VALUE IS SET = 7777. C L=12 --USED INITIALLY IN ESTABLISHING C MOSTORE( , ). LATER USED AS A WAY OF C DETERMINING WHETHER TO KEEP THIS C VARIABLE. C ND9 = THE SECOND DIMENSION OF LSTORE( , ). (INPUT) C CORE(J) = THE ARRAY TO STORE OR RETRIEVE THE DATA C IDENTIFIED IN LSTORE( , ) (J=1,ND10). WHEN C CORE( ) IS FULL DATA ARE STORED ON DISK. C (OUTPUT) C ND10 = DIMENSION OF CORE( ). (INPUT) C NBLOCK = THE BLOCK SIZE IN WORDS OF THE MOS-2000 RANDOM C DISK FILE. (INPUT) C NFETCH = INCREMENTED EACH TIME GFETCH IS ENTERED. C IT IS A RUNNING COUNT FROM THE BEGINNING OF C THE PROGRAM. THIS COUNT IS MAINTAINED IN C CASE THE USER NEEDS IT (DIAGNOSTICS, ETC.). C NEEDS IT (DIAGNOSTICS, ETC.). (INTERNAL) C IS0(J) = MOS-2000 GRIB SECTION 0 ID'S (J=1,3). C (INTERNAL) C IS1(J) = MOS-2000 GRIB SECTION 1 ID'S (J=1,22+). 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 IS4. NOT ALL C LOCATIONS ARE USED. (INPUT) C ISTAV = SET TO 0 TO INDICATE A GRID FIELD IS BEING RE- C TURNED. (OUTPUT) C L3264B = INTEGER WORD LENGTH IN BITS OF MACHINE BEING C USED (EITHER 32 OR 64). (INPUT) C L3264W = NUMBER OF WORDS IN 64 BITS, EITHER 1 OR 2. C (INPUT) C IER = STATUS RETURN. (OUTPUT) C 0 = GOOD RETURN. C 103 = REQUESTED PREDICTOR ID IS NOT SUPPORTED. C SEE GFETCH AND CONST FOR OTHER VALUES. WHEN AN C ERROR IS ENCOUNTERED, MISSING VALUES ARE ENTERED C FOR THE DESIRED VARIABLE. (OUTPUT) C C OTHER VARIABLES C LD(J) = HOLDS THE 4 ID WORDS OF THE DATA RETRIEVED INTO C FD1( ) (J=1,4). (INTERNAL) C MISSP = PRIMARY MISSING VALUE INDICATOR. RETURNED AS C ZERO WHEN DATA ARE NOT PACKED. (INTERNAL) C MISSS = SECONDARY MISSING VALUE INDICATOR. RETURNED AS C ZERO WHEN DATA ARE NOT PACKED. (INTERNAL) C NPACK = 2 FOR TDL GRIB PACKED DATA: 1 FOR NOT PACKED. C THIS IS STORED IN LSTORE(7, ). (INTERNAL) C NWORDS = NUMBER OF WORDS RETURNED IN DATA( ). (INTERNAL) C C NONSYSTEM SUBROUTINES CALLED C GFETCH C C*********************************************************************** PARAMETER (NX=1089,NY=641,NPROJ=5) ! master NA 10km PS grid C PARAMETER (NUMVAR=12) ! NUMBER OF VARIABLES ACCOMMODATED PARAMETER (NUMPASS=4) ! NUMPASS IS NUMBER OF CALLS TO SMTH9VW C CHARACTER*8 CCALL(ND1,6) C REAL FD1(NX,NY),FD2(NX,NY),FD3(ND2X3),FD4(ND2X3),FD5(ND2X3) REAL FD6(ND2X3),FDSINS(ND2X3),FDMS(ND2X3),DATA(ND5),CORE(ND10) REAL DIR(ND1,2,ND11),WT(NUMPASS,NUMVAR),WRK(NX,NY) REAL TRUNC(3,NUMVAR) C INTEGER IDPARS(15),ID(4),LD(4),LDPARS(15),IPACK(ND5) INTEGER LSTORE(12,ND9),NGRIDC(6,ND11),IWORK(ND5),ITABLE(2,NUMVAR) INTEGER IS0(ND7),IS1(ND7),IS2(ND7),IS4(ND7) C C LIST OF RAP VARIABLES BELOW DATA ITABLE/007801,007800, ! CREF (INGESTED) 2 003355,003350, ! PW (INGESTED) 3 007011,007010, ! LI (INGESTED) 4 007811,007810, ! VIL (INGESTED) 5 007101,007100, ! CAPE (INGESTED) 6 003202,003200, ! 1H PRECIP (INGESTED) 7 003231,003230, ! 1H CNV PRECIP (INGESTED) 8 003501,003501, ! MOISTURE DIV (COMPUTED) 9 007651,007650, ! LTG THREAT (INGESTED) X 004031,004030, ! U WIND SHEAR (INGESTED) 1 004131,004130, ! V WIND SHEAR (INGESTED) 2 007809,007808/ ! ECHO TOP (INGESTED) C DATA TRUNC/0.0, 0.00, 0.00, ! CREF 2 1.0, 0.00, 75.00, ! PW 3 1.0, -15.00, 25.00, ! LI 4 1.0, 0.00, 46.00, ! VIL 5 0.0, 0.00, 0.00, ! CAPE 6 1.0, 0.00, 50.00, ! 1H PC 7 0.0, 0.00, 0.00, ! 1H CNV PC 8 1.0,-2500.00, 1500.00, ! MDIV 9 0.0, 0.00, 9.00, ! LTG THREAT X 0.0, -999.00, 999.00, ! U WIND SHEAR 1 0.0, -999.00, 999.00, ! V WIND SHEAR 2 0.0, 0.00, 0.00/ ! ECHO TOP C DATA ((WT(I,J),I=1,NUMPASS),J=1,NUMVAR) ! SMOOTHING WEIGHT 1 /1.00,0.85,0.00,0.00, ! CREF 2 1.00,0.85,0.00,0.00, ! PW 3 1.00,0.85,0.00,0.00, ! LI 4 1.00,1.00,0.00,0.00, ! VIL 5 1.00,1.00,0.50,0.00, ! CAPE 6 1.00,1.00,0.00,0.00, ! 1H PC 7 1.00,1.00,0.00,0.00, ! 1H CNV PC 8 1.00,1.00,1.00,1.00, ! SFC MOISTURE DIV 9 1.00,1.00,0.50,0.00, ! LTG THREAT X 1.00,1.00,0.00,0.00, ! U WIND SHEAR 1 1.00,1.00,0.00,0.00, ! V WIND SHEAR 2 1.00,1.00,0.00,0.00/ ! ECHO TOP C DATA NCHECK/1/,RMISS/9999.0/ C C CALL TIMPR(KFILDO,KFILDO,'START RAPGRD ') C IER=0 C C CHECK TO SEE IF VARIABLE IS ACCOMMODATED IN THIS ROUTINE. C IVAR=0 DO NN=1,NUMVAR IF((IDPARS(1).EQ.ITABLE(1,NN)/1000).AND. 1 (IDPARS(2).EQ.MOD(ITABLE(1,NN),1000))) THEN ID1IN=ITABLE(2,NN) IVAR=NN END IF END DO C C IF IVAR IS STILL 0, THE VARIABLE IS NOT ACCOMODATED. C PRINT ERROR MESSAGE AND RETURN MISSING DATA. C IF (IVAR.EQ.0) THEN C WRITE(KFILDO,20)(ID(J),J=1,4) 20 FORMAT(/,' **** VARIABLE ',4I11.9,' NOT ACCOMMODATED IN RAPGRD', 1 ' ... SET IER=103 AND SUPPLY MISSING VALUES') C DO N=1,ND5 DATA(N)=RMISS END DO IER=103 ISTAV=0 NSLAB=NCHECK RETURN ! EXITING SUBROUTINE END IF C C FOR MDIV (IVAR=8) A SPECIAL COMPUTATION NEEDS TO BE DONE. C LOGIC HERE IS FOR PROCESSING ANY OTHER VARIABLE. C IF (IVAR.NE.8) THEN C C CALL GFETCH TO FETCH RAP GRID C LD(1)=(ID1IN*1000)+IDPARS(4) LD(2)=0 LD(3)=ID(3) LD(4)=0 C C DIAGNOSTIC PRINT C C WRITE(KFILDO,105) NDATE,ID,LD,IDPARS(12) C105 FORMAT(' AT 105 IN RAPGRD - NDATE, ID, LD, IDPARS(12):', C 1 I10,2(3X,4I11.9),I6) C CALL GFETCH(KFILDO,KFIL10,LD,7777,LSTORE,ND9,LITEMS, 1 IS0,IS1,IS2,IS4,ND7,IPACK,IWORK,FD1,ND2X3, 2 NWORDS,NPACK,NDATE,NTIMES,CORE,ND10,NBLOCK, 3 NFETCH,NSLAB,MISSP,MISSS,L3264B,1,IER) C IF (IER.NE.0) THEN WRITE(KFILDO,110) NDATE,ID,LD 110 FORMAT(' FOR NDATE ID =',I10,2X,4I10.9,' INGEST GRID LD =', 1 4I10.9,' IS MISSING. SUPPLY MISSING VALUES AND', 2 ' RETURN.') C DO N=1,ND5 DATA(N)=RMISS END DO ISTAV=0 NSLAB=NCHECK RETURN ! EXITING SUBROUTINE END IF C C FOR IVAR=8, DO MOISTURE DIVERGENCE COMPUTATION C ELSE IF (IVAR.EQ.8) THEN C C COMPUTE MOISTURE DIVERGENCE (AT 2M) C LD(1)=ID(1) LD(2)=ID(2) LD(3)=ID(3) LD(4)=0 C C DIAGNOSTIC PRINT C C WRITE(KFILDO,155) NDATE,ID,LD,IDPARS(12) C155 FORMAT(' AT 155 IN RAPGRD - NDATE, ID, LD, IDPARS(12):', C 1 I10,2(3X,4I11.9),I6) C CALL PRSID1(KFILDO,LD,LDPARS) CALL MDIV(KFILDO,KFIL10,LD,LDPARS,NDATE, 1 NGRIDC,ND11,NSLAB,IPACK,IWORK,DATA,ND5, 2 LSTORE,ND9,LITEMS,CORE,ND10,NBLOCK,NFETCH, 3 IS0,IS1,IS2,IS4,ND7, 4 FD1,FD2,FD3,FD4,FD5,FD6,FDSINS,FDMS,ND2X3, 5 ISTAV,L3264B,MISTOT,IER) C C IF AN ERROR COMES FROM MDIV, PRINT A MESSAGE, SUPPLY C MISSING VALUES, AND RETURN. C IF(IER.NE.0) THEN C WRITE(KFILDO,160) IER 160 FORMAT(/,' **** IER = ',I4,' RETURNED FROM MDIV. SUPPLY', 1 ' MISSING VALUES AND RETURN.') C DO N=1,ND5 DATA(N)=RMISS END DO ISTAV=0 NSLAB=NCHECK RETURN ! EXITING SUBROUTINE END IF C C SAFETY CHECK: MAKE SURE IS2(3)=NX AND IS2(4)=NY C IF(IS2(3).NE.NX.OR.IS2(4).NE.NY) THEN WRITE(KFILDO,180) NX,NY,IS2(3),IS2(4) 180 FORMAT(/,' NX, NY = ',2I6,' DOES NOT MATCH WITH IS2(3),', 1 ' IS2(4) = ',2I6,' STOP 180 IN RAPGRD') STOP 180 C C add w3tag stop routine here C END IF C C TRANSFER DATA( ) TO 2-DIM ARRAY [FD1( , )] C NN=0 DO J=1,NY DO I=1,NX NN=NN+1 FD1(I,J)=DATA(NN) END DO END DO C END IF C C FOR CREF AND ECHO TOP, TRUNCATE NEGATIVE (INDETERMINITE) C VALUES TO 0. C IF (IVAR.EQ.1.OR.IVAR.EQ.12) THEN DO J=1,NY DO I=1,NX IF (FD1(I,J).LT.0.0) FD1(I,J)=0.0 END DO END DO END IF C C TRUNCATE VARIABLE AS DEFINED IN TRUNC( , ) ARRAY. C TRUNC(1, ) = 1 MEANS PERFORM TRUNCATION; 0 OTHERWISE C TRUNC(2, ) IS THE LOWER TRUNCATION BOUND. C TRUNC(3, ) IS THE UPPER TRUNCATION BOUND. C IF (NINT(TRUNC(1,IVAR)).EQ.1) THEN C C INITIALIZE COUNTERS FOR TRUNCATION RESULTS. C NTRUNCLO=0 NTRUNCHI=0 C C PERFORM TRUNCATION C DO J=1,NY DO I=1,NX IF (FD1(I,J).LT.9998.5) THEN IF (FD1(I,J).LT.TRUNC(2,IVAR)) THEN FD1(I,J)=TRUNC(2,IVAR) NTRUNCLO=NTRUNCLO+1 END IF IF (FD1(I,J).GT.TRUNC(3,IVAR)) THEN FD1(I,J)=TRUNC(3,IVAR) NTRUNCHI=NTRUNCHI+1 END IF END IF END DO END DO C C DIAGNOSTIC PRINT FOR TRUNCATION, IF IT OCCURRED. C IF ((NTRUNCLO.GT.0).OR.(NTRUNCHI.GT.0)) THEN WRITE(KFILDO,480) NDATE,(ID(K),K=1,4),NTRUNCLO,TRUNC(2,IVAR), 1 NTRUNCHI,TRUNC(3,IVAR) 480 FORMAT(' ON DATE ',I10,' FOR VARIABLE ',4I11.9,' THERE WERE', 1 I6,' VALUES BELOW ',F8.2,' AND ',I6,' VALUES ABOVE', 2 F8.2,' TRUNCATED.') END IF C END IF ! TRUNCATION C C APPLY SMOOTHING TO FD1(NX,NY) C DO NN=1,NUMPASS IF(WT(NN,IVAR).NE.0.0) THEN C WRITE(KFILDO,*) 'SMTH9VW IVAR WT ', IVAR,WT(NN,IVAR) CALL SMTH9VW(FD1,NX,NY,WT(NN,IVAR),WRK,RMISS,1) ENDIF ENDDO C C RETURN GRIDDED OUTPUT VARIABLE IN ONE-DIMENSION OUTPUT ARRAY C [DATA( )]. C NN=0 DO J=1,NY DO I=1,NX NN=NN+1 DATA(NN)=FD1(I,J) ENDDO ENDDO C C DATA( ) IS RETURNED AS A GRID. SO SET ISTAV=0. ALSO, NSLAB C MUST BE SET TO NCHECK, WHERE THE LATTER WAS SET IN FIRST ENTRY C AND THEN SAVED. C ISTAV=0 NSLAB=NCHECK C 999 RETURN END