SUBROUTINE HRRRGRD(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 JULY 2015 SAMPLATSKY MDL MOS-2000 C OCTOBER 2015 CHARBA CHANGED NAME FROM CHGRDID TO HRRRGRD, C GREATLY MODIFIED, AND ADDED CALL TO C MDIV). C OCTOBER 2015 CHARBA REVISED THE 9-PT WT'D HRRR GRID SMOOTH- C ING (3KM GRID) TO USE A TELESCOPING C WINDOW SIZE (LARGE-TO-SMALL) ACROSS THE C MULTIPLE PASSES. C OCTOBER 2015 CHARBA MODIFIED SUCH THAT FOR HRRR PROJECTIONS C GT 15H (GRID) DATA RETURNED IS FOR THE C 15H PROJECTION (B/C HRRR DATA ARE NOT C AVAILABLE FOR THESE PROJECTIONS). C NOVEMBER 2015 CHARBA THIS VERSION RENDERS LCC 1799X1059 3KM C HRRR GRID TO LCC 1201X897 5KM LAMP C GRIDBOXES, WHICH IS DONE BY ASSIGNING C THE AVG HRRR VALUE IN A 5KM GRIDBOX. C WHEN IPBOX=0 THE 5KM GRIDBOX IS CEN- C TERED WRT LAMP GRID COORDINATE; WHEN C IPBOX=1 THE GRIDBOX IS POSITIONED WRT C LOWER-LEFT CORNER. IPBOX IS SET TO 1 C FOR CONSISTENCY WITH SIMILAR MRMS/TL C GRIDDING. NOTE THAT THIS HRRRGRD C VERSION INCLUDES NGRID IN ARG LIST C SINCE A NEW GRID IS DEFINED WITHIN. C NOVEMBER 2015 CHARBA ADDED AN ADDITIONAL HRRR VARIABLE TO C PROCESS ...LIGHTNING THREAT. C NOVEMBER 2015 CHARBA MODIFIED TO RETURN A 10KM GRID CONTAIN- C ING THE SMOOTHED PEAK 5KM AVG IN A 2X2 C WINDOW (10KM GRIDBOX). THIS REQ ADDING C SPECS FOR 3RD GRID, WHICH IS THE (NEW) C OUTPUT GRID ...THESE NEW GRID SPECS ARE C SAVED FOR USE IN PRED23/24. C NOVEMBER 2015 CHARBA APPLIED SMOOTHING TO RAW MDIV BEFORE C RENDERING TO 5KM AVG. PP SMOOTHING FOR C MDIV NOT CHGD. C NOVEMBER 2015 CHARBA REDUCED PP SMOOTHING FOR MDIV. ALSO C SET RAW (UNDEFINED) CREF (=-10.0 DBZ) C TO 0.0 BEFORE RENDERING TO 5KM GRID C AVG. THE LATTER IS NECESSARY B/C THE C RECENTLY MOD VERSION OF CNVTGRD (WHICH C SAVES THE ABS MAX IN A 2X2 WINDOW) C RETAINS -10.0 RATHER THAN POS VALUES C < 10.0 (NOT VALID). C NOVEMBER 2015 CHARBA 1. GREATLY REDUCED "PREP" SMOOTHING FOR C MDIV (1 PASS) AND RETAINED PREVIOUS C "POST" SMOOTHING (1 PASS). 2. INCREASED C POST SM TO 2 PASSES. C DECEMBER 2015 CHARBA ADDED DOC FOR CHANGES FRED C MADE ON 11/26/2015, WHICH WERE: IN THE C CASE WHERE THE HRRR INGEST GRIDS ARE C MISSING, MISSING VALUES ARE SUPPLIED C TO THE CORRESPONDING OUTPUT GRID. ALSO C IN THIS CASE THE (NEW) OUTPUT GRID SPECS C ARE SUPPLIED FOR UPSTREAM ROUTINES C ...ELSE A CORE DUMP WILL OCCUR. C JANUARY 2016 CHARBA CHANGED SUCH THAT WHEN A HRRRX GRID IS C AVAILABLE FOR "EXTENDED" PROJECTIONS IT C IS USED. ELSE THE 15H (FROZEN) HRRR C FORECAST IS USED FOR EXTENDED PROJEC- C TIONS. PREVIOUSLY, THE FROZEN 15H HRRR C GRID WAS USED REGARDLESS WHETHER THE C HRRRX GRID WAS AVAILABLE. C APRIL 2016 CHARBA FOR "EXTENDED" PROJECTIONS MODIFIED C SUCH THAT A PERSISTED 18H HRRR FORECAST C IS USED WHEN AVAILABLE. C APRIL 2016 CHARBA RESTRUCTURED AND SIMPLIFIED HRRR GRID C INGEST TO MAKE 15H OR 18H HRRR GRID C "PERSISTENCE" WORK CORRECTLY. WITH C REVISED STRUCTURE ONLY ONE CALL TO C GFETCH IS EXECUTED ON EACH ENTRY: IF C GFETCH RETURNS DATA SUCCESSFULLY PRO- C CEED AS BEFORE, BUT SAVE DATE, ID(1), C AND RENDERED/SMOOTHED GRID. IF GFETCH C RETURNS AN ERROR AND THE DATE-ID FROM C PREVIOUS ENTRY HAS NOT CHANGED JUST C USE THE SAVED GRID FROM PREVIOUS ENTRY. C APRIL 2016 SAMPLATSKY ADDED LOGIC TO TRUNCATE EACH C VARIABLE TO A SPECIFIED LOWER AND UPPER C BOUND. C MAY 2016 CHARBA MADE MINOR (FINAL) ADJS TO TRUNC BOUNDS C JUNE 2016 CHARBA ADDED TRUNC BOUNDS FOR MRMS CREF. OOPS C MISTAKE ...THOUGHT THIS WAS MRMS CODE C REVERSED THIS MISTAKEN CHANGE. C APRIL 2017 SAMPLATSKY UPDATED ITABLE FOR FINAL IDS. C JUNE 2017 SAMPLATSKY COMMENTED SOME REMNANT DIAGNOSTIC C PRINT STATEMENTS. C SEPTEMBER 2020 SAMPLATSKY COMMENTED A COUPLE PRINTS THAT C ARE NOT NECESSARY IN NORMAL RUNS. C C PURPOSE C ORIGINALLY DESIGNED TO INGEST HRRR GRIDS. C C SUBROUTINE JUST READS IN A GRID AND RETURNS IT IN DATA( ). C THIS ALLOWS FOR CHANGING THE ID OF THE INGEST GRID, AND C RETURNING DATA( ) AS A GRID ALLOWS FOR SMOOTHING AND C COMPUTATION OF GRID BINARIES. C C THE FOLLOWING IDPARS(1) AND IDPARS(2) ARE ACCOMMODATED. C 007 - 670 COMPOSITE REFLECTIVITY (INGESTED) C 003 - 350 PRECIP WATER (INGESTED) C 007 - 010 LIFTED INDEX (INGESTED) C 007 - 806 VERTICALLY INTEGRATED LIQUID (INGESTED) C 007 - 100 CAPE (INGESTED) C 003 - 200 1H PRECIP AMT (INGESTED) C 003 - 501 MOISTURE DIV (COMPUTED HERE) C 007 - 680 LIGHTNING THREAT 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(HMESH=3000.0, HORIENT=-97.5, HSTNLAT=38.5, 1 HLATLL=21.138, HLONLL=-122.720, NHPROJ=3, 2 NX=1799, NY=1059) ! Input hrrr grid specs C PARAMETER(XMESHL2=5079.406, ORIENT2=-95.0, XLAT2=25.0, ! 5km grid c 1 XLATLL2=16.2810, XLONLL2=-126.1380,NPROJ2=3, ! mrms ctl 1 XLATLL2=16.2809, XLONLL2=-126.1380,NPROJ2=3, ! in table 2 NX2=1201, NY2=897, IPBOX=1) ! lower-lft 5km box c 2 NX2=1201, NY2=897, IPBOX=0) ! centered 5km box C PARAMETER(XMESHL3=10158.813, ORIENT3=95.0, XLAT3=25.0, ! 10km grid 1 XLATLL3=16.2809, XLONLL3=126.1380,NPROJ3=3, 2 NX3=601,NY3=449) C PARAMETER (NUMVAR=8) ! NUMBER OF VARIABLES ACCOMMODATED c PARAMETER (NUMPASS=5) ! NUMPASS IS NUMBER OF CALLS TO SMTH9VW PARAMETER (NUMPASS=3) ! NUMPASS IS NUMBER OF CALLS TO SMTH9VW PARAMETER (NUMPASS1=5) ! 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), 1 FD6(ND2X3),FDSINS(ND2X3),FDMS(ND2X3) C INTEGER IDPARS(15),ID(4),LD(4),LDPARS(15),IPACK(ND5) INTEGER LSTORE(12,ND9),NGRIDC(6,ND11),IWORK(ND5),ITABLE(2,NUMVAR) c INTEGER IS0(ND7),IS1(ND7),IS2(ND7),IS4(ND7),IWIN(NUMPASS,NUMVAR) INTEGER IS0(ND7),IS1(ND7),IS2(ND7),IS4(ND7),IWIN1(NUMPASS1,NUMVAR) c INTEGER IS0(ND7),IS1(ND7),IS2(ND7),IS4(ND7) C c REAL DATA(ND5),CORE(ND10),DIR(ND1,2,ND11),WT(NUMPASS,NUMVAR) REAL DATA(ND5),CORE(ND10),DIR(ND1,2,ND11),WT(NUMPASS,NUMVAR), 1 WT1(NUMPASS1,NUMVAR) C REAL GRDOUT(NX2,NY2),TRUNC(3,NUMVAR) C INTEGER,ALLOCATABLE :: IXHROUT(:,:) ! X-COORD OF HRRR GP IN OUTGRD INTEGER,ALLOCATABLE :: JYHROUT(:,:) ! Y-COORD OF HRRR GP IN OUTGRD INTEGER,ALLOCATABLE :: KNTHROUT(:,:) ! COUNT OF HRRR GPS IN OUTGRD REAL,ALLOCATABLE :: WRK1(:,:) ! OUTPUT GRID FOR GIVEN ENTRY C c REAL WRK1(NX3,NY3),WRK2(NX3,NY3) REAL WRK2(NX3,NY3) ! WRK1( , ) NOW ALLOCATED C DATA ITABLE/007801,007800, ! CREF (INGESTED) 1 003355,003350, ! PW (INGESTED) 2 007011,007010, ! LI (INGESTED) 3 007811,007810, ! VIL (INGESTED) 4 007101,007100, ! CAPE (INGESTED) 5 003202,003200, ! 1H PC (INGESTED) 6 003501,003501, ! MOISTURE DIV (COMPUTED) 7 007651,007650/ ! LTG THREAT (INGESTED) C DATA ((WT1(I,J),I=1,NUMPASS1),J=1,NUMVAR) ! SMOOTHING WEIGHT...3km 1 /1.00,1.00,1.00,0.50,0.00, ! CREF (na) 2 1.00,1.00,1.00,0.50,0.00, ! PW (na) 3 1.00,1.00,1.00,0.50,0.00, ! LI (na) 4 1.00,1.00,1.00,0.75,0.00, ! VIL (na) 5 1.00,1.00,1.00,1.00,0.00, ! CAPE (na) 6 1.00,1.00,1.00,0.50,0.00, ! 1H PC (na) 7 1.00,0.00,0.00,0.00,0.00, ! SFC MOISTURE DIV 8 1.00,1.00,1.00,0.50,0.00/ ! LTG THREAT (na) C DATA ((IWIN1(I,J),I=1,NUMPASS1),J=1,NUMVAR) !SMOOTHING WINDOW..3km 1 /3 ,2 ,1 ,1 ,1 , ! CREF (na) 2 3 ,2 ,1 ,1 ,1 , ! PW (na) 3 3 ,2 ,1 ,1 ,1 , ! LI (na) 4 3 ,2 ,1 ,1 ,1 , ! VIL (na) 5 3 ,2 ,1 ,1 ,1 , ! CAPE (na) 6 3 ,2 ,1 ,1 ,1 , ! 1H PC (na) 7 1 ,1 ,1 ,1 ,1 , ! SFC MOISTURE DIV 8 3 ,2 ,1 ,1 ,1 / ! LTG THREAT (na) C DATA TRUNC/0.0, 0.00, 0.00, ! CREF 1 1.0, 0.00, 75.00, ! PW 2 1.0, -15.00, 25.00, ! LI 3 1.0, 0.00, 46.00, ! VIL 4 0.0, 0.00, 0.00, ! CAPE 5 1.0, 0.00, 50.00, ! 1H PC 6 1.0,-2500.00, 1500.00, ! MDIV 7 1.0, 0.00, 9.00/ ! LTG THREAT C DATA ((WT(I,J),I=1,NUMPASS),J=1,NUMVAR) ! SMOOTHING WEIGHT ...10km 1 /1.00,0.50,0.00, ! CREF 2 1.00,0.50,0.00, ! PW 3 1.00,0.90,0.00, ! LI 4 1.00,1.00,0.00, ! VIL 5 1.00,1.00,0.50, ! CAPE 6 1.00,1.00,0.00, ! 1H PC 7 1.00,1.00,0.00, ! SFC MOISTURE DIV 8 1.00,0.60,0.00/ ! LTG THREAT C DATA IFIRST/0/,IGCK/0/,ID1PRV/0/IDATPRV/0/,ID1PRV/0/,IFIRSTW/0/ C SAVE IDATPRV,ID1PRV,WRK1,IXHROUT,JYHROUT,KNTHROUT,IGCK,NCHECK, 1 IFIRST,IFIRSTW C C CALL TIMPR(KFILDO,KFILDO,'START HRRRGRD ') C C ALLOCATE AND SAVE OUTPUT GRID ARRAY SINCE IT MAY USED IN C SUBSEQUENT ENTRY. C IF(IFIRSTW.EQ.0) THEN ALLOCATE (WRK1(NX3,NY3)) ! OUTPUT GRID FOR ANY ENTRY IFIRSTW=1 ENDIF C IER=0 C C CHECK TO SEE IF VARIABLE IS ACCOMMODATED IN THIS ROUTINE. C DO 10 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 IF(ID1IN.EQ.003501) THEN GO TO 100 ENDIF GOTO 30 END IF 10 CONTINUE C C VARIABLE NOT ACCOMMODATED. PRINT ERROR MESSAGE AND RETURN C MISSING DATA. C WRITE(KFILDO,20)(ID(J),J=1,4) 20 FORMAT(/,' **** VARIABLE ',4I11.9,' NOT ACCOMMODATED IN HRRRGRD', 1 ' ... SET IER=103 AND SUPPLY MISSING VALUES') GOTO 800 C C CALL GFETCH TO FETCH HRRR GRID C 30 LD(1)=(ID1IN*1000)+IDPARS(4) LD(2)=0 LD(3)=ID(3) LD(4)=0 C C write(kfildo,105) ndate,id,ld,IDPARS(12) 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.EQ.0) THEN C SAVE DATE AND ID(1) SINCE RENDERED OUTPUT GRID (OBTAINED C BELOW) MAY BE NEEDED ON NEXT ENTRY. IDATPRV=NDATE ID1PRV=ID(1)/1000 ELSE ! INGEST GRID NOT AVAILABLE SO NEED TO SPECIFY "OUTGRID." WRITE(KFILDO,32) NDATE,ID,LD 32 FORMAT(' FOR NDATE ID =',I10,2X,4I10.9,' INGEST GRID LD =', 1 4I10.9,' IS MISSING; MUST SPECIFY OUTPUT GRID RETURNED') C write(kfildo,33) ndate,idatprv,id(1)/1000,id1prv,idpars(12) C 33 format(' ndate idatprv id1/1000 id1prv,idpars(12) =',5i12) IF(NDATE.EQ.IDATPRV.AND.ID(1)/1000.EQ.ID1PRV.AND. 1 IDPARS(12).GT.15) THEN C SUPPLY OUTPUT GRID FROM PREV ENTRY AND RETURN. IER=0 GO TO 550 ELSE C GRID FROM PREV ENTRY NOT APPROP--SUPPLY MISSING AND RETURN IER=0 GO TO 800 ENDIF ENDIF C C INGEST GRID OBTAINED ...PROCEED WITH RENDERING C C CK IF 'NWORDS' IS NX*NY. IF NOT 'STOP 36'. C IF(NWORDS.NE.NX*NY) THEN WRITE(KFILDO,36) NX*NY,NWORDS 36 FORMAT(/,'NX*NY, NWORDS =',2I10,' SINCE THESE DO NOT MATCH', 1 ' STOP 36 IN HRRRGRD') STOP 36 ENDIF GO TO 400 C C COMPUTE MOISTURE DIVERGENCE (AT 2M) C 100 LD(1)=ID(1) LD(2)=ID(2) LD(3)=ID(3) LD(4)=0 C write(kfildo,105) ndate,id,ld,IDPARS(12) C105 format(' ndate id ld IDPARS(12) = ',i10,2x,2(4i10.9,3x),i4) 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 IF(IER.EQ.0) THEN C SAVE DATE AND ID(1) SINCE RENDERED OUTPUT GRID (OBTAINED C BELOW) MAY BE NEEDED ON NEXT ENTRY. IDATPRV=NDATE ID1PRV=ID(1)/1000 ELSE ! INGEST GRID NOT AVAILABLE SO NEED TO SPECIFY "OUTGRID." WRITE(KFILDO,110) NDATE,ID,LD 110 FORMAT(' FOR NDATE ID =',I10,2X,4I10.9,' INGEST GRID LD =', 1 4I10.9,' IS MISSING; MUST SPECIFY OUTPUT GRID RETURNED') C write(kfildo,33) ndate,idatprv,id(1)/1000,id1prv,idpars(12) IF(NDATE.EQ.IDATPRV.AND.ID(1)/1000.EQ.ID1PRV.AND. 1 IDPARS(12).GT.15) THEN C SUPPLY OUTPUT GRID FROM PREV ENTRY AND RETURN. IER=0 GO TO 550 ELSE C GRID FROM PREV ENTRY NOT APPROP--SUPPLY MISSING AND RETURN GO TO 800 IER=0 ENDIF ENDIF C C MAKE SURE IS2(3)=NX AND IS2(4)=NY C IF(IS2(3).NE.NX.OR.IS2(4).NE.NY) THEN WRITE(KFILDO,120) NX,NY,IS2(3),IS2(4) 120 FORMAT(/,' NX, NY = ',2I6,' DOES NOT MATCH WITH IS2(3),', 1 ' IS2(4) = ',2I6,' STOP 120 IN HRRRGRD') STOP 120 ENDIF C C TRANSFER DATA( ) TO 2-DIM ARRAY [FD1( , )] C NN=0 DO JY=1,NY DO IX=1,NX NN=NN+1 FD1(IX,JY)=DATA(NN) ENDDO ENDDO C C PERFORM SMOOTHING (ONLY) ON MDIV RAW GRID C c200 DO 300 II=1,NUMPASS c IF (WT(II,IVAR).NE.0.0) THEN c WRITE(KFILDO,*) 'SMTH9VW IVAR, WT, IWIN ', IVAR, WT(II,IVAR), c 1 IWIN(II,IVAR) c CALL SMTH9VW(FD1,NX,NY,WT(II,IVAR),FD2,9999.,IWIN(II,IVAR)) c ENDIF c300 CONTINUE DO 300 II=1,NUMPASS1 IF (WT1(II,IVAR).NE.0.0) THEN WRITE(KFILDO,*) 'SMTH9VW IVAR, WT1, IWIN1 ', 1 IVAR, WT1(II,IVAR),IWIN1(II,IVAR) CALL SMTH9VW(FD1,NX,NY,WT1(II,IVAR),FD2,9999.,IWIN1(II,IVAR)) ENDIF 300 CONTINUE C 400 IF(ID1IN.EQ.907670) THEN C CHG NEG RAW HRRR CREF TO 0.0 SINCE APPEARS UNDEFINED CREF IS C SET TO -10.0 DBZ. NEGCREF=0 DO J=1,NY DO I=1,NX IF(FD1(I,J).LT.0.0) THEN NEGCREF=NEGCREF+1 FD1(I,J)=0.0 ENDIF ENDDO ENDDO WRITE(KFILDO,410) ID1IN,NX*NY,NEGCREF 410 FORMAT(' ID1 NX*NY NEGCREF ',3I10,' SET TO 0.0 BEFORE', 1 ' RENDERING') ENDIF C*********************************************************************** C C RENDER HRRR GRID TO 5KM GRID. FIRST INITIALIZE LATTER TO 9999. C DO JJ=1,NY2 DO II=1,NX2 GRDOUT(II,JJ)=9999. ENDDO ENDDO C C ON FIRST ENTRY ALLOCATE ARRAYS THAT SAVE THE X- AND Y-COORD OF C EACH HRRR GP IN AN OUTPUT GRIDBOX. ALSO ALLOCATE AND SAVE AN C ARRAY CONTAINING THE NUMBER OF HRRR GPS FALLING IN EACH OUTPUT C GRIDBOX. C IF(IFIRST.EQ.0) THEN C ALLOCATE (IXHROUT(NX,NY)) ! X-COORD OF HRRR GP IN "OUT-GRID" ALLOCATE (JYHROUT(NX,NY)) ! Y-COORD OF HRRR GP IN "OUT-GRID" ALLOCATE (KNTHROUT(NX2,NY2)) ! COUNT OF HRRR GPS IN "OUT-GRID" KNT=0 ! NUMBER OF HRRR GPS IN "OUT-GRID" C INITIALIZE KNTHROUT( , ) TO 0 ! ...ONLY ON FIRST ENTRY DO JJ=1,NY2 DO II=1,NX2 KNTHROUT(II,JJ)=0 ENDDO ENDDO C RENDER EACH HRRR GP TO OUTPUT GRIDBOX ...ONLY ON FIRST ENTRY DO J=1,NY DO I=1,NX RI=I RJ=J C COMPUTE LAT/LONG OF HRRR GRIDPOINT CALL W3FB12(RI,RJ,HLATLL,HLONLL,HMESH,HORIENT,HSTNLAT, 1 RLAT,RLON,IERR) IF(IERR.NE.0) THEN WRITE(KFILDO,450) I,J,IERR 450 FORMAT(' LAT/LONG FOR HRRR I AND J = ',2I5,' CANNOT BE', 1 ' COMPUTED ...STOP 450') STOP 450 ENDIF C COMPUTE X- AND Y-COORDS (IN OUTPUT GRID) OF HRRR GP. CALL W3FB11(RLAT,RLON,XLATLL2,XLONLL2,XMESHL2,ORIENT2,XLAT2, 1 X2I,Y2J) IF(IPBOX.EQ.0) THEN C HRRR GP FALLS WITHIN "CENTERED" OUTPUT GRIDBOX IH=NINT(X2I) JH=NINT(Y2J) ELSE C HRRR GP FALLS WITHIN "LOWER-LEFT POSITIONED" OUTPUT C GRIDBOX. IH=X2I JH=Y2J ENDIF IF ((IH.LT.1).OR.(IH.GT.NX2)) CYCLE IF ((JH.LT.1).OR.(JH.GT.NY2)) CYCLE KNT=KNT+1 C SAVE HRRR GP LOCATION IN OUTPUT GRID (IH,JH). IXHROUT(I,J)=IH JYHROUT(I,J)=JH C ASSIGN HRRR GP VALUE TO OUTPUT GRIDBOX. KNTHROUT(IH,JH)=KNTHROUT(IH,JH)+1 ! HRRR GP COUNT (FOR AVG) IF(GRDOUT(IH,JH).EQ.9999.) THEN GRDOUT(IH,JH)=FD1(I,J) ELSE ! FOR AVG GRDOUT(IH,JH)=GRDOUT(IH,JH)+FD1(I,J) ENDIF ENDDO ENDDO C C COMPUTE HRRR AVG VALUE IN OUTPUT GRIDBOX C miscnt=0 DO JJ=1,NY2 DO II=1,NX2 IF(KNTHROUT(II,JJ).GT.0) THEN ! ck for 0 knthrout( , ) GRDOUT(II,JJ)=GRDOUT(II,JJ)/KNTHROUT(II,JJ) ELSE miscnt=miscnt+1 c WRITE(KFILDO,455) II,JJ c455 FORMAT(//' NO HRRR GP IN OUTPUT GRID BOX FOR II JJ = '2I6, c 1 ' SET GRDOUT(II,JJ)=9999. AND CONTINUE') GRDOUT(II,JJ)=9999. ENDIF ENDDO ENDDO IFIRST=1 c write(kfildo,460) ((ixhrout(i,j),i=1,nx,100),j=1,ny,100) c460 format(' 1st entry ixhrout = ',/,(10i10)) c write(kfildo,465) ((jyhrout(i,j),i=1,nx,100),j=1,ny,100) c465 format(' 1st entry jyhrout = ',/,(10i10)) ELSE c write(kfildo,470) ((ixhrout(i,j),i=1,nx,100),j=1,ny,100) c470 format(' 2nd entry ixhrout = ',/,(10i10)) c write(kfildo,475) ((jyhrout(i,j),i=1,nx,100),j=1,ny,100) c475 format(' 2nd entry jyhrout = ',/,(10i10)) C SPECIFY HRRR VALUE IN OUTPUT GRIDBOX (FOR SUBSEQ ENTRIES). KNT=0 DO J=1,NY DO I=1,NX KNT=KNT+1 IH=IXHROUT(I,J) JH=JYHROUT(I,J) IF(GRDOUT(IH,JH).EQ.9999.) THEN GRDOUT(IH,JH)=FD1(I,J) ELSE ! FOR AVG GRDOUT(IH,JH)=GRDOUT(IH,JH)+FD1(I,J) ENDIF ENDDO ENDDO C COMPUTE AVG VALUE IN OUTPUT GRIDBOX miscnt=0 DO JJ=1,NY2 DO II=1,NX2 IF(KNTHROUT(II,JJ).GT.0) THEN ! ck for 0 knthrout( , ) GRDOUT(II,JJ)=GRDOUT(II,JJ)/KNTHROUT(II,JJ) ELSE c WRITE(KFILDO,455) II,JJ miscnt=miscnt+1 GRDOUT(II,JJ)=9999. ENDIF ENDDO ENDDO C ENDIF C C*********************************************************************** C C HRRR GRID RENDERING TO OUTPUT GRID "2" (5KM) NOW COMPLETE. C CALL TO CNVTGRD TRANSFORMS GRDOUT( , ) TO PROVIDE THE MAX VALUE C IN A 2X2 WINDOW (10KM GRIDBOX)IN FD1( , ). SINCE IPBOX IS SET C TO 1 THE 10KM GRIDBOX IS CENTERED ON (I,J). C ISWITCH=0 ! PROVIDES MAX VALUE IN 2X2 WINDOW CALL CNVTGRD(GRDOUT,NX2,NY2,WRK1,NX3,NY3,ISWITCH) 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,NY3 DO I=1,NX3 IF (WRK1(I,J).LT.9998.5) THEN IF (WRK1(I,J).LT.TRUNC(2,IVAR)) THEN WRK1(I,J)=TRUNC(2,IVAR) NTRUNCLO=NTRUNCLO+1 END IF IF (WRK1(I,J).GT.TRUNC(3,IVAR)) THEN WRK1(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 C C APPLY SMOOTHING TO WRK1(NX3,NY3) 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(WRK1,NX3,NY3,WT(NN,IVAR),WRK2,9999.,1) ENDIF ENDDO C C SET 10KM OUTPUT GRID SPECS TO APPROP U202 ARRAYS IF NOT ALREADY C DONE ON A PREVIOUS ENTRY. C C FIRST, SET IS2( ) TO OUTPUT GRID SPECS. C IS2(2)=NPROJ3 IS2(3)=NX3 IS2(4)=NY3 IS2(5)=XLATLL3*10000 IS2(6)=XLONLL3*10000 IS2(7)=ORIENT3*10000 IS2(8)=XMESHL3*1000 IS2(9)=XLAT3*10000 C C CHECK IF NEW OUTPUT GRID IS ALREADY STORED. C IF(IGCK.EQ.0) THEN C NCHECK=0 DO 500 N=1,NGRID ! NGRID - # UNIQUE INPUT GRIDS IN U202.CN IF(NGRIDC(1,N).EQ.IS2(2).AND. 1 NGRIDC(2,N).EQ.IS2(8).AND. 2 NGRIDC(3,N).EQ.IS2(9).AND. 3 NGRIDC(4,N).EQ.IS2(7).AND. 4 NGRIDC(5,N).EQ.IS2(5).AND. 5 NGRIDC(6,N).EQ.IS2(6)) NCHECK=N C C OUTPUT GRID PREVIOUSLY STORED, SO NO NEED TO STORE IT C AGAIN. C IF(NCHECK.GT.0) GO TO 550 500 CONTINUE C C MUST STORE REQUIRED ITEMS FOR NEW OUTPUT GRID. C IF(NGRID+1.GT.ND11) THEN WRITE(KFILDO,510) NGRID+1 510 FORMAT(/,' ****ERROR IN HRRRGRD; ND11 MUST BE INCREASED', 1 ' TO ',I3,' ...SUPPLY MISSING VALUES AND SET IER', 2 ' = 53') IER=53 GO TO 800 ENDIF C NGRID=NGRID+1 NCHECK=NGRID ! NCHECK MUST BE SAVED FOR SUBSEQ ENTRIES C C STORE THE GRID PARAMETERS. C NGRIDC(1,NGRID)=IS2(2) NGRIDC(2,NGRID)=IS2(8) NGRIDC(3,NGRID)=IS2(9) NGRIDC(4,NGRID)=IS2(7) NGRIDC(5,NGRID)=IS2(5) NGRIDC(6,NGRID)=IS2(6) C C NOTE: DIR( , , ) NEED NOT BE SET SINCE IT IS NOT USED IN C PRED23/24 [IT IS USED FOR INTERPOLATION IN C U201/PRED21(22)], SO IF THIS WERE U201 DIR( , , ) C WOULD NEED TO BE SET HERE. C C GOT CORE DUMP IN PACKGP W/O ABOVE SO NOW PUTTING C DIR( , , ) ASSIGNMENT BACK IN. C DO 520 K=1,NSTA ! NSTA - # OF PTS IN U202.CN LIST READ(CCALL(K,1),'(I4,4X)',ERR=650) IX READ(CCALL(K,1),'(4X,I4)',ERR=650) IY DIR(K,1,NGRID)=IX DIR(K,2,NGRID)=IY 520 CONTINUE IGCK=1 C ENDIF C C RETURN GRIDDED OUTPUT VARIABLE IN ONE-DIMENSION OUTPUT ARRAY C [DATA( )]. C 550 NN=0 DO JJ=1,NY3 DO II=1,NX3 NN=NN+1 DATA(NN)=WRK1(II,JJ) 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 write(kfildo,570) nslab,nx2,ny2,nx*ny,knt,nx2*ny2,miscnt,nx3,ny3, C 1 id C 570 format(' in hrrrgrd at label 570 nslab nx2 ny2 nx*ny knt nx2*ny2', C 1 ' miscnt nx3 ny3 id = ',9i10,2x,4i10.9) C stop 570 C C CALL TIMPR(KFILDO,KFILDO,'END HRRRGRD ') C GOTO 999 C 650 WRITE(KFILDO,660) 660 FORMAT(/,' ****ERROR READING CALL LETTERS IN HRRRGRD ...SUPPLY ', 1 'MISSING VALUES TO GRID AND SET IER=33') IER=33 C C SET OUTPUT GRID TO MISSING WHEN AN ERROR HAS OCCURRED. C 800 IER=0 ISTAV=0 IS2(2)=NPROJ3 IS2(3)=NX3 IS2(4)=NY3 IS2(5)=XLATLL3*10000 IS2(6)=XLONLL3*10000 IS2(7)=ORIENT3*10000 IS2(8)=XMESHL3*1000 IS2(9)=XLAT3*10000 NSLAB=NCHECK DO 810 N=1,NX3*NY3 DATA(N)=9999. 810 CONTINUE C 999 RETURN END