SUBROUTINE RAP_1HCNVPP(KFILDO,KFIL10,IP12,KFILRA,RACESS, 1 NUMRA,ID,IDPARS,JD,ITAU, 2 NDATE,MDATE,CCALL,ISDATA,SDATA,ND1,NSTA, 3 ICALLD,CCALLD,IPACK,IWORK,DATA,ND5, 4 LSTORE,ND9,LITEMS,CORE,ND10, 5 NBLOCK,NFETCH,LASTL,LASTD, 6 IS0,IS1,IS2,IS4,ND7, 7 ISTAV,ISTAB,L3264B,L3264W,IER) C C MARCH 2020 SHAFER ADAPTED FROM BLMP_1HCNVPP C SEPTEMBER 2020 SAMPLATSKY UPDATED PROCESSING ID C C PURPOSE C TO PERFORM POST-PROCESSING OF RAP MOS GRIDDED 1-H CONV PROBS C FOR OVERLAPPING REGIONS. THE INPUT CONSISTS OF PRIMARY AND SEC- C ONDARY PROBS, EACH FOR MULTIPLE OVERLAPPING REGIONS. THE C PROB GRID FOR A GIVEN OVERLAPPING REGION CONSISTS OF VALID C PROBS WITHIN THE REGION AND MISSING VALUES OUTSIDE THE REG- C ION. TO OBTAIN THE PROB GRID BASED ON ALL REGIONS, THE REG- C IONAL PROBS ARE COMPOSITED. THE COMPOSITING IS CONTROLLED C BY THE REGIONAL WEIGHTING CONSTANTS. FOR POINTS WITHIN A C REGION THE WEIGHT VALUE IS 1.0 FOR A NON-OVERLAP POINT AND C SOME VALUE WITHIN THE 0.0 - 1.0 RANGE FOR AN OVERLAP POINT. C FOR POINTS OUTSIDE THE REGION THE WEIGHT VALUE IS MISSING. C THE COMPOSITING FOR THE FULL DOMAIN IS PERFORMED BY WEIGHT- C ING THE REGIONAL PROBS OVER ALL REGIONS. C C THE ROUTINE CONSISTS OF FOLLOWING SERIAL STEPS: C 1. ON FIRST ENTRY, INITIALIZATION IS PERFORMED WHICH IN- C CLUDES INGESTING AND STORING THE REGIONAL WEIGHT CON- C STANTS. C 2. FOR A GIVEN REGION, THE PRIMARY AND BACKUP PROBS ARE C INGESTED AND COMPOSITED (MISSING PRIMARY PROBS ARE C REPLACED WITH SECONDARY PROBS). C 3. THE COMPOSITED PROB VALUES ARE WEIGHTED ACCORDING TO C WEIGHTS FOR THE REGION. C 4. STEPS 2 AND 3 ARE REPEATED FOR ALL REGIONS, WHICH C YIELDS THE COMPOSITED PROB FIELD FOR THE CONUS DOMAIN. C 5. THE COMPOSITED PROS ARE TRUNCATED TO THE 0.0 - 1.0 C RANGE. C 6. THE COMPOSITED AND TRUNCATED PROBS ARE SPATIALLY C SMOOTHED TO YIELD THE FINAL PROB FIELD. C C THE FOLLOWING IDPARS(1) AND IDPARS(2) ARE ACCOMMODATED: C 207 760 - POST-PROCESSED 1-HR CONV PROB (DD=03) 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 IP12 - INDICATES WHETHER (>1) OR NOT (=0) THE LIST OF C STATIONS ON THE INPUT FILES WILL BE PRINTED TO C THE FILE WHOSE UNIT NUMBER IS IP12. C C VARIABLES C KFILDO = DEFAULT UNIT NUMBER FOR OUTPUT (PRINT) FILE. C (INPUT) C KFIL10 = UNIT NUMBER OF TDL MOS-2000 FILE SYSTEM C ACCESS. (INPUT-OUTPUT) C IP12 = INDICATES WHETHER (>0) OR NOT (=0) THE LIST OF C STATIONS ON THE EXTERNAL RANDOM ACCESS FILES C WILL BE LISTED TO UNIT IP12. (INPUT) C KFILRA(J) = THE UNIT NUMBERS FOR WHICH RANDOM ACCESS FILES C ARE AVAILABLE (J=1,NUMRA). (INPUT) C RACESS(J) = THE FILE NAMES ASSOCIATED WITH KFILRA(J) C (J=1,NUMRA). (CHARACTER*60) (INPUT) C NUMRA = THE NUMBER OF VALUES IN KFILRA( ) AND RACESS( ). C (INPUT) C ID(J) = ID OF VARIABLE BEING PROCESSED (J=1,4). (INPUT) C IDPARS(J) = THE PARSED, INDIVIDUAL COMPONENTS OF THE C PREDICTAND 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), WHICH IN THIS C CASE IS RELATIVE TO THE MOS CYCLE TIME, C NOT THE LAMP CYCLE TIME. C J=13--I (INTERPOLATION TYPE) C J=14--S (SMOOTHING INDICATOR) C J=15--G (GRID INDICATOR). C JD(J) = THE BASIC VARIABLE IDS (J=1,4). C THIS IS THE SAME AS ID(J), 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 THRESH. C JD( ) IS USED TO IDENTIFY THE BASIC MODEL C FIELDS AS READ FROM THE ARCHIVE. (INPUT) C LD(J) = THE VARIABLE ID (J=1,4) USED TO FETCH REGIONAL C WEIGHTS AND THEN PQPFS. (INTERNAL) C LDPARS(J) = AS FOR IDPARS(J) EXCEPT PERTAINING TO LD(J). C (INTERNAL) C ITAU = THE NUMBER OF HOURS AHEAD TO FIND A VARIABLE. C THIS HAS ALREADY BEEN CONSIDERED IN MDATE, BUT C IS NEEDED FOR CALL TO RETVEC. (INPUT) C NDATE = THE DATE/TIME FOR WHICH VARIABLE IS BEING PRO- C CESSED. (INPUT) C MDATE = NDATE UPDATED WITH ITAU. (INPUT) C NSTA = NUMBER OF STATIONS OR LOCATIONS BEING DEALT C WITH. (INPUT) C CCALL(K,J) = 8-CHARACTER STATION CALL LETTERS (OR GRIDPOINT C LOCATIONS FOR GRID DEVELOPMENT) TO PROVIDE C OUTPUT FOR (J=1) AND 5 POSSIBLE OTHER STATION C CALL LETTERS (J=2,6) THAT CAN BE USED INSTEAD C IF THE PRIMARY (J=1) STATION CANNOT BE FOUND C IN AN INPUT DIRECTORY (K=1,NSTA). ALL STATION C DATA ARE KEYED TO THIS LIST, EXCEPT POSSIBLY C CCALLD( ). EQUIVALENCED TO ICALL( , , ) IN C DRU201. (CHARACTER*8; INPUT) C ND1 = MAXIMUM NUMBER OF STATIONS THAT CAN BE DEALT C WITH. DIMENSION OF IX( ), IY( ), SDATA ( ), C ISDATA( ), WDATA( ), PDATA( ), AND FIRST DIMEN- C SION OF CCALL( ,6). (INPUT) C ISDATA(K) = WORK ARRAY (K=1,ND1). (INTERNAL) C SDATA(K) = WORK ARRAY AND RETURNED DATA (K=1,ND1). C (INTERNAL/OUTPUT) C WDATA(K) = WORK ARRAY USED TO FETCH DATA IN CONST AND C RETVEC (K=1,ND1). (INTERNAL/AUTOMATIC) C PDATA(K) = WORK ARRAY USED TO HOLD COMPOSITE OF PRIMARY AND C SECONDARY PROBS. (INTERNAL/AUTOMATIC) C ND5 = DIMENSION OF IPACK( ), IWORK( ), DATA( ), C CCALLD( ), FD1( ), FD2( ), AND SECOND DIMENSION C OF ICALLD( , ). (INPUT) C ICALLD(L,K) = 8 STATION CALL LETTERS AS CHARACTERS IN AN INTE- C GER VARIABLE (L=1,L3264W) (K=1,ND5). THIS ARRAY C IS USED TO READ THE STATION DIRECTORY FROM A C MOS-2000 EXTERNAL FILE. EQUIVALENCED TO C CCALLD( ) IN DRU710. (INTERNAL) C CCALLD(K) = 8 STATION CALL LETTERS (K=1,ND5). THIS ARRAY IS C USED IN CONST TO READ THE STATION DIRECTORY. C EQUIVALENCED TO ICALLD( , ) IN DRU710. C (CHARACTER*8; INTERNAL) C IPACK(J) = WORK ARRAY (J=1,ND5). (INTERNAL) C IWORK(J) = WORK ARRAY (J=1,ND5). (INTERNAL) C DATA(K) = WORK ARRAY (J=1,ND5). (INTERNAL) 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 MSTORE( , ). LATER USED AS A WAY OF C DETERMINING WHETHER TO KEEP THIS C VARIABLE. C ND9 = THE SECOND DIMENSION OF LSTORE( , ) THAT HAVE C BEEN USED IN THIS RUN. (INPUT) C LITEMS = NUMBER OF MOS FORECAST FIELDS HELD IN THE MOS C INTERNAL STORAGE SYSTEM. (INPUT) C ND10 = DIMENSION OF CORE( ). (INPUT) C CORE(J) = THE ARRAY TO STORE OR RETIREVE THE DATA C IDENTIFIED IN LSTORE( , ) (J=1,ND10). WHEN C CORE( ) IS FULL DATA ARE STORED ON DISK. C (OUTPUT) C NBLOCK = THE BLOCK SIZE IN WORDS OF THE MOS-2000 RANDOM C DISK FILE. (INPUT) C NFETCH = INCREMENTED EACH TIME RETVEC/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 LASTL = THE LAST LOCATION IN CORE( ) USED. THIS MAY BE C MODIFIED, ALONG WITH ITEMS, IF COMPACTION IS C DONE BY GCPAC. INITIALIZED TO ZERO ON FIRST C ENTRY TO GSTORE. MUST BE CARRIED WHENEVER C GSTORE IS TO BE CALLED. (INPUT-OUTPUT) C LASTD = TOTAL NUMBER OF PHYSICAL RECORDS ON DISK. C INITIALIZED TO ZERO ON FIRST ENTRY TO GSTORE. C MUST BE CARRIED WHENEVER GSTORE IS TO BE CALLED. C (INPUT-OUTPUT) 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 = 1 SINCE THE DATA RETURNED ARE STATION DATA. C 0 WHEN THE DATA RETURNED ARE GRID DATA OR DATA C ARE NOT AVAILABLE FOR RETURN. RETURNED C FROM SOME COMPUTATIONAL ROUTINES THAT CAN C BE USED IN U201. NOT NEEDED IN OPTX, SINCE C ALL DATA ARE STATION ORIENTED. (OUTPUT) C ISTAB = 1 WHEN THE VARIABLE RETURNED IS BINARY; C 0 OTHERWISE. (INTERNAL) 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 CALCULATED BY PARAMETER, BASED ON L3464B. C (INPUT) C IER = STATUS RETURN. C 0 = GOOD RETURN. C 47 = GRIDPOINT IDS COULD NOT BE CONVERTED. C 103 = WHEN THE VARIABLE ID IS NOT ACCOMMODATED. C SEE CONST AND RETVEC FOR OTHER VALUES. WHEN C IER NE 0, DATA ARE RETURNED AS MISSING. C (INTERNAL-OUTPUT) C C OTHER VARIABLES C LDPARS(J) = AS FOR IDPARS( ) BUT PERTAINING TO LD( ) C (J=1,15). (INTERNAL) C LD(J) = WORK ARRAY FOR VARIABLE IDS FOR WHICH DATA IS C RETRIEVED FROM INTERNAL OR EXTERNAL STORAGE C (J=1,4). (INTERNAL) C NUMREG = NUMBER OF REGIONS FOR WHICH WEIGHTS AND PQPFS C ARE INGESTED. (PARAMETER) C IDWT(J,K) = HOLDS VARIABLE IDS FOR THE REGIONAL WEIGHTS C (J=1,4) (K=1,NUMREG). (INTERNAL) C WEIGHT(I,K) = HOLDS THE REGIONAL WEIGHTS (I=1,NSTA) C (K=1,NUMREG). (INTERNAL/ALLOCATED) C NX = NUMBER OF GRID POINTS IN THE X-DIRECTION C ...NEEDED FOR SMOOTHING. (PARAMETER) C NY = NUMBER OF GRID POINTS IN THE Y-DIRECTION C ...NEEDED FOR SMOOTHING. (PARAMETER) C IX(K) = X-COORDINATES OF STATIONS ...NEEDED FOR SMOOTH- C ING (K=1,NSTA). (INTERNAL/ALLOCATED) C IY(K) = Y-COORDINATES OF STATIONS ...NEEDED FOR SMOOTH- C ING (K=1,NSTA). (INTERNAL/ALLOCATED) C GRD1(I,J) = WORK ARRAY USED FOR SMOOTHING (I=1,NX, C J=1,NY). (INTERNAL/AUTOMATIC) C GRD2(I,J) = WORK ARRAY USED FOR SMOOTHING (I=1,NX, C J=1,NY). (INTERNAL/AUTOMATIC) C IFIRST = SET TO 0 TO GET GRID COORDINATES AND RETRIEVE C CONSTANT DATA ON FIRST ENTRY; SET TO 1 OTHER- C WISE. (INTERNAL) C C NONSYSTEM SUBROUTINES CALLED C RETVEC, SMTH9VW, PRSID1, CONST C PARAMETER (NX=413,NY=277,NUMREG=3,NUMPRB=3,MAXPROJ=39) C CHARACTER*8 CCALL(ND1,6) CHARACTER*8 CCALLD(ND5) CHARACTER*60 RACESS(NUMRA) C INTEGER, ALLOCATABLE, DIMENSION(:) :: IX INTEGER, ALLOCATABLE, DIMENSION(:) :: JY REAL, ALLOCATABLE, DIMENSION (:,:) :: WEIGHT C DIMENSION IPACK(ND5),IWORK(ND5),DATA(ND5),ICALLD(L3264W,ND5) C DIMENSION SDATA(ND1),ISDATA(ND1),REGPRBS(NUMPRB,ND1) DIMENSION WDATA(ND1),PDATA(ND1),WREGSUM(ND1),WPRBSUM(ND1,NUMREG) C DIMENSION IDPARS(15),ID(4),LDPARS(15),LD(4),JD(4),IDWT(4,NUMREG), 1 WTPRB(NUMPRB,MAXPROJ),WTSPSM(MAXPROJ) C DIMENSION IS0(ND7),IS1(ND7),IS2(ND7),IS4(ND7) DIMENSION LSTORE(12,ND9),CORE(ND10) C DIMENSION KFILRA(NUMRA) C DIMENSION GRD1(NX,NY),GRD2(NX,NY) ! AUTOMATIC ARRAYS C DATA ((IDWT(I,J),I=1,4),J=1,NUMREG) 1 /447999001,0,0,0, ! WEIGHTS FOR REGION 01 2 447999002,0,0,0, ! WEIGHTS FOR REGION 02 3 447999003,0,0,0/ ! WEIGHTS FOR REGION 03 C DATA ((WTPRB(I,J),I=1,NUMPRB),J=1,MAXPROJ) 1 /1.00, 0.00, 0.00, ! 1 2 1.00, 0.00, 0.00, ! 2 3 1.00, 0.00, 0.00, ! 3 4 1.00, 0.00, 0.00, ! 4 5 0.75, 0.25, 0.00, ! 5 6 0.50, 0.50, 0.00, ! 6 7 0.25, 0.75, 0.00, ! 7 8 0.00, 1.00, 0.00, ! 8 9 0.00, 1.00, 0.00, ! 9 X 0.00, 1.00, 0.00, ! 10 1 0.00, 1.00, 0.00, ! 11 2 0.00, 1.00, 0.00, ! 12 3 0.00, 0.75, 0.25, ! 13 4 0.00, 0.50, 0.50, ! 14 5 0.00, 0.25, 0.75, ! 15 6 0.00, 0.00, 1.00, ! 16 7 0.00, 0.00, 1.00, ! 17 8 0.00, 0.00, 1.00, ! 18 9 0.00, 0.00, 1.00, ! 19 X 0.00, 0.00, 1.00, ! 20 1 0.00, 0.00, 1.00, ! 21 2 0.00, 0.00, 1.00, ! 22 3 0.00, 0.00, 1.00, ! 23 4 0.00, 0.00, 1.00, ! 24 5 0.00, 0.00, 1.00, ! 25 6 0.00, 0.00, 1.00, ! 26 7 0.00, 0.00, 1.00, ! 27 8 0.00, 0.00, 1.00, ! 28 9 0.00, 0.00, 1.00, ! 29 X 0.00, 0.00, 1.00, ! 30 1 0.00, 0.00, 1.00, ! 31 2 0.00, 0.00, 1.00, ! 32 3 0.00, 0.00, 1.00, ! 33 4 0.00, 0.00, 1.00, ! 34 5 0.00, 0.00, 1.00, ! 35 6 0.00, 0.00, 1.00, ! 36 7 0.00, 0.00, 1.00, ! 37 8 0.00, 0.00, 1.00, ! 38 9 0.00, 0.00, 1.00/ ! 39 C DATA (WTSPSM(J),J=1,MAXPROJ) ! FINAL SPATIAL SMOOTHING WTS 1 /0.700, ! 1 2 0.650, ! 2 3 0.600, ! 3 4 0.550, ! 4 5 0.500, ! 5 6 0.450, ! 6 7 0.400, ! 7 8 0.380, ! 8 9 0.360, ! 9 X 0.340, ! 10 1 0.320, ! 11 2 0.300, ! 12 3 0.280, ! 13 4 0.260, ! 14 5 0.240, ! 15 6 0.220, ! 16 7 0.200, ! 17 8 0.180, ! 18 9 0.160, ! 19 X 0.140, ! 20 1 0.120, ! 21 2 0.100, ! 22 3 0.100, ! 23 4 0.100, ! 24 5 0.100, ! 25 6 0.100, ! 26 7 0.100, ! 27 8 0.100, ! 28 9 0.100, ! 29 X 0.100, ! 30 1 0.100, ! 31 2 0.100, ! 32 3 0.100, ! 33 4 0.100, ! 34 5 0.100, ! 35 6 0.100, ! 36 7 0.100, ! 37 8 0.100, ! 38 9 0.100/ ! 39 C SAVE IX,JY,IFIRST,WEIGHT C C CHECK IF THIS CODE ACCOMMODATES POST-PROCESSING OF GRIDDED LAMP C CONVEC OR LTG PROBS. C ICHECK=0 IPRBCHECK=0 IF (IDPARS(1).EQ.207.AND.IDPARS(2).EQ.760) ICHECK=1 ! LAMP 1H CNV PRB C IF (ICHECK.NE.1) THEN IER=103 WRITE(KFILDO,100) IDPARS(1),IDPARS(2),IER 100 FORMAT(/,' ****IDPARS(1) AND IDPARS(2)= ',2I4, 1 ' NOT ACCOMMODATED IN RAP_1HCNVPP ...SET IER =',I4, 2 ' AND RETURN MISSING VALUES') GOTO 900 END IF C C INITIALIZE GRD1( , ) FOR SMOOTHING OPERATIONS ...NEEDS TO BE C DONE ONLY ONCE SINCE SMOOTHING ROUTINE PRESERVES MISSING C VALUES. C DO J=1,NY DO I=1,NX GRD1(I,J)=9999.0 END DO END DO C C FIRST ENTRY PROCESSING. C - CHECK WTPRB( , ) ARRAY FOR WEIGHT SUMS OVER NUMPRB INGESTED C PROBS = 1. C - PRINT VALUES OF WTPRB( , ) AND WTSPSM( ) ARRAYS FOR EASY C REFERENCE. C - READ AND STORE GRID COORDINATES. C - INGEST REGIONAL WEIGHTS. C IF(IFIRST.EQ.0) THEN C C VALIDITY CHECK ON WTPRB( , ) ARRAY C DO KK=1,MAXPROJ SUM=0.0 DO LL=1,NUMPRB SUM=SUM+WTPRB(LL,KK) END DO IF (SUM.NE.1.0) THEN WRITE(KFILDO,150) KK,SUM 150 FORMAT(/,' **** IN RAP_1HCNVPP FOR PROJ ',I3,' THE SUM ', 1 ' OF WEIGHTS IN WTPRB( , ) ARRAY = ',F6.3, 2 ' WHICH IS INVALID. STOP 150') STOP 150 END IF END DO C C PRINT VALUES FROM WTPRB( , ) AND WTSPSM( ) ARRAYS. C WRITE(KFILDO,155) 155 FORMAT(/,' WEIGHTS TO APPLY TO EACH EQUATION TIER FOR EACH', 1 ' PROJECTION.', 1 /,3X,2X,' 1 2 3 ') DO KK=1,MAXPROJ WRITE(KFILDO,160) KK,(WTPRB(LL,KK),LL=1,NUMPRB) 160 FORMAT(I3,3(1X,F5.2,1X)) END DO C WRITE(KFILDO,165) 165 FORMAT(/,' SPATIAL SMOOTHING WEIGHTS, BY PROJECTION.') DO KK=1,MAXPROJ WRITE(KFILDO,170) KK,WTSPSM(KK) 170 FORMAT(I3,F7.3) END DO C C GET GRID COORDINATES FROM GRIDPOINT IDS AND SAVE THEM IN C ALLOCATED ARRAYS. C ALLOCATE(IX(ND1),STAT=IOS) ALLOCATE(JY(ND1),STAT=IOS) DO K=1,NSTA READ(CCALL(K,1),'(I4.4,4X)',ERR=800) IX(K) READ(CCALL(K,1),'(4X,I4.4)',ERR=800) JY(K) END DO C C FETCH WEIGHTING CONSTANTS FOR EACH REGION FROM A VECTOR CON- C STANT FILE. THE WEIGHTS ARE STORED IN AN ALLOCATED ARRAY AND C SAVED FOR USE IN SUBSEQUENT CALLS. C ALLOCATE(WEIGHT(ND1,NUMREG),STAT=IOS) C C INITIALIZE SUMMED REGIONAL WEIGHTS ...FOR VALIDITY CK BELOW C DO K=1,NSTA WREGSUM(K)=0.0 ! SUMMED REGIONAL WTS OVER ALL REGIONS ENDDO C DO 200 NR=1,NUMREG LD(1)=IDWT(1,NR) LD(2)=IDWT(2,NR) LD(3)=IDWT(3,NR) LD(4)=IDWT(4,NR) CALL PRSID1(KFILDO,LD,LDPARS) CALL CONST(KFILDO,KFIL10,IP12, 1 LD,LDPARS,LD,NDATE, 2 KFILRA,RACESS,NUMRA, 3 CCALL,ICALLD,CCALLD, 4 ISDATA,WDATA,ND1,NSTA, 5 IPACK,IWORK,DATA,ND5, 6 LSTORE,ND9,LITEMS,CORE,ND10,LASTL, 7 NBLOCK,LASTD,NSTORE,NFETCH, 8 IS0,IS1,IS2,IS4,ND7, 9 ISTAV,L3264B,L3264W,IER) IF(IER.NE.0)THEN WRITE(KFILDO,190) (LD(J),J=1,4),NDATE,(ID(J),J=1,4) 190 FORMAT(/,' **** IN RAP_1HCNVPP, COULD NOT', 1 ' FETCH REGION WTS CONSTANT DATA FOR ',4I10.9, 2 ' FROM RANDOM ACCESS VECTOR FILE.',/, 3 ' CONTINUE BUT MISSING VALUES WILL BE RETURNED', 4 ' FOR DATE =',I10,' AND ID( ) = ',4I10.9) ENDIF C C COPY CONSTANT DATA INTO WEIGHT( , ) C DO K=1,NSTA WEIGHT(K,NR)=WDATA(K) WREGSUM(K)=WREGSUM(K)+WEIGHT(K,NR) END DO C 200 CONTINUE ! DO NR=1,NUMREG C C PERFORM VALIDITY CK ON SUMMED REGIONAL WTS C IRWTERR=0 DO K=1,NSTA IF (WREGSUM(K).LT.0.999.OR.WREGSUM(K).GT.1.001) THEN IRWTERR=IRWTERR+1 END IF END DO IF (IRWTERR.NE.0) THEN WRITE(KFILDO,210) IRWTERR 210 FORMAT(' ****IN RAP_1HCNVPP IRWTERR = ',I7, 1 ' INSTEAD IRWTERR SHOULD BE 0 ...STOP 210') STOP 210 END IF C C SET IFIRST TO 1 SO THAT THE ABOVE PROCESSING STEPS ARE PER- C FORMED ONLY ON THE FIRST ENTRY. C IFIRST=1 C END IF ! IF IFIRST=0 C C IF AN ERROR OCCURRED DURING RETRIEVAL OF WEIGHTS, EXIT WITH C MISSING VALUES FOR OUTPUT VARIABLE. C IF(IER.GT.0) GOTO 900 C C PERFORM WEIGHTING OF TWO REGIONAL PROB TYPES TO OBTAIN COMP- C OSITE PROBS. THIS REQUIRES TWO TYPES OF WEIGHTING: FIRST C WEIGHTING IS ACROSS TWO PROB TYPES AND SECOND WEIGHTING IS C ACROSS REGIONS. FIRST INITIALIZE SEVERAL WORKING ARRAYS TO 0.0. C DO K=1,NSTA SDATA(K)=0.0 ! COMPOSITE OF REG PROBS ACROSS ALL REGS DO NR=1,NUMREG WPRBSUM(K,NR)=0.0 ! SUMMED PROB TYPE WTS FOR REGION NR END DO END DO C NPROJ=IDPARS(12) NERRFLG=0 C DO 400 NR=1,NUMREG IERRCNT=0 ! COUNTER FOR UNFETCHABLE PROB TYPES IPRBCNT=0 ! COUNTER FOR NON-MISSING WEIGHTED PROBS DO K=1,NSTA PDATA(K)=0.0 ! COMPOSITE PROBS WITHIN A SINGLE REGION DO NP=1,NUMPRB REGPRBS(NP,K)=9999.0 END DO END DO DO 350 NP=1,NUMPRB C C INGEST A REGIONAL PROB TYPE C IF(NP.EQ.1) MDLNUM=10+NR IF(NP.EQ.2) MDLNUM=20+NR IF(NP.EQ.3) MDLNUM=30+NR C LD(1)=207750100+MDLNUM ! RAW REGIONAL 1H CONV PRB LD(2)=ID(2) LD(3)=ID(3) LD(4)=ID(4) C c WRITE(KFILDO,305) NDATE,(ID(J),J=1,4),(LD(J),J=1,4) c 305 FORMAT (/,' FOR DATE ',I10,' FOR ID = ',4I10.9, c 1 /,' ',10X,' FETCH ID = ',4I10.9) C CALL PRSID1(KFILDO,LD,LDPARS) CALL RETVEC(KFILDO,KFIL10,IP12,KFILRA,RACESS,NUMRA, 1 LD,LDPARS,JD,ITAU, 2 NDATE,MDATE,CCALL,ISDATA,WDATA,ND1,NSTA, 3 ICALLD,CCALLD,IPACK,IWORK,DATA,ND5, 4 LSTORE,ND9,LITEMS,CORE,ND10, 5 NBLOCK,NFETCH, 6 IS0,IS1,IS2,IS4,ND7, 7 L3264B,L3264W,IER) C IF(IER.NE.0)THEN WRITE(KFILDO,310) (LD(J),J=1,4),NDATE 310 FORMAT(/,' **** IN RAP_1HCNVPP AT LABEL 310, COULD NOT', 1 ' FETCH PROB FOR ',4I10.9,' FOR DATE = ',I10,/, 2 ' ...CONTINUE AS THIS MAY NOT BE AN ERROR') IERRCNT=IERRCNT+1 ELSE DO K=1,NSTA REGPRBS(NP,K)=WDATA(K) END DO C C SPOT CHECK LOWER LEFT CORNER FOR NON-MISSING VALUE C IF(WDATA(1).NE.9999.) IPRBCHECK=1 END IF 350 CONTINUE ! DO NP=1,NUMPRB C C PERFORM PROBABILITY WEIGHTING ACROSS NUMPRB PROBS, FOR C WHEN WTPRB(NP,NPROJ) IS NONZERO. FOR THE PURPOSE OF C WEIGHTING, IF A 9997 IS ENCOUNTERED (EXTREMELY UNLIKELY) C SET IT TO 0. C DO 355 NP=1,NUMPRB IF (WTPRB(NP,NPROJ).GT.0.0) THEN DO K=1,NSTA IF (WEIGHT(K,NR).GT.0.0) THEN c IF (REGPRBS(NP,K).GT.9996.5.AND.REGPRBS(NP,K).LT.9998.5) IF (REGPRBS(NP,K).GT.9996.5) 1 REGPRBS(NP,K)=0.0 C C ONLY PERFORM WEIGHTING FOR NON-MISSING PROBS. C IF (REGPRBS(NP,K).LT.9998.5) THEN PDATA(K)=PDATA(K)+WTPRB(NP,NPROJ)*REGPRBS(NP,K) WPRBSUM(K,NR)=WPRBSUM(K,NR)+WTPRB(NP,NPROJ) IPRBCNT=IPRBCNT+1 END IF END IF END DO END IF C c WRITE(KFILDO,330) NR,IDPARS(12),NP,IERRCNT,IPRBCNT c330 FORMAT(/,' AT 330, NR,IDPARS(12),NP,IERRCNT,IPRBCNT = ',5I7) C 355 CONTINUE ! DO NP=1,NUMPRB C c WRITE(KFILDO,360) NDATE,NR,IDPARS(12),IERRCNT,IPRBCNT c360 FORMAT(/,' AFTER 350 LOOP IN RAP_1HCNVPP, NDATE, REG, PROJ,', c 1 ' IERRCNT, IPRBCNT = ',5I10) C C IERRCNT=NUMPRB MEANS AN ERROR WAS RETURNED FROM RETVEC C FOR ALL TIERS OF INGEST PROBABILITIES. IPRBCNT=0 MEANS C THE ENTIRE REGION IS FILLED WITH MISSING PROBABILITIES. C IF EITHER HAPPENS, SET NERRFLG=1 AND PRINT A MESSAGE. C IF(IERRCNT.EQ.NUMPRB.OR.IPRBCNT.EQ.0) THEN WRITE(KFILDO,370) NDATE,NR,IERRCNT,IPRBCNT 370 FORMAT(/,' AT 370 IN RAP_1HCNVPP, FOR DATE ',I10,' AND', 1 ' REGION ',I3,' IERRCNT = ',I3,' OR IPRBCNT = 0.', 2 /,' MISSING PROBS WERE READ IN. SET NERRFLG = 1', 3 ' TO RETURN MISSING DATA.') NERRFLG=1 ELSE C C CHECK THAT WTPRBSUM( , ) CONTAINS A VALID SUM FOR C THE REGION. ALL POINTS SHOULD HAVE A VALUE OF 0 OR C 1. ANY OTHER VALUE INDICATES A PROBLEM, MOST LIKELY C THE RESULT OF A TRUNCATED HRRR RUN. C INOTVLD=0 DO K=1,NSTA IF(WPRBSUM(K,NR).GT.0.0.AND.WPRBSUM(K,NR).NE.1.0) THEN INOTVLD=INOTVLD+1 ENDIF ENDDO C C IF INOTVLD GOT SET ABOVE, PRINT A MESSAGE AND SET NERRFLG C TO 1, SO MISSING DATA WILL BE RETURNED. C IF (INOTVLD.GT.0) THEN WRITE(KFILDO,380) NDATE,NR,INOTVLD 380 FORMAT(/,' AT 380 IN RAP_1HCNVPP, FOR DATE ',I10,' AND', 1 ' REGION ',I3,' THERE ARE ',I7,' POINTS WITH AN', 2 ' INVALID WTPRBSUM.',/,' SET NERRFLG = 1 TO', 3 ' RETURN MISSING DATA.') NERRFLG=1 END IF END IF C C PERFORM REGIONAL WEIGHTING OF MERGED (NON-MISSING) PROBS. c ALSO, SUM THE REGIONAL WEIGHT AT EACH PT IN DOMAIN. C ONLY PERFORM WEIGHTING IF NERRFLG=0, AS OTHER VALUES MEAN C MISSING PROBABILITIES EXIST IN PDATA( ). C IF (NERRFLG.EQ.0) THEN DO K=1,NSTA IF (WEIGHT(K,NR).GT.0.0) THEN SDATA(K)=SDATA(K)+PDATA(K)*WEIGHT(K,NR) END IF END DO END IF C 400 CONTINUE ! DO NR=1,NUMREG C C IF NERRFLG GOT SET TO A NONZERO VALUE IN THE DO 400 LOOP, C IT MEANS UNEXPECTED MISSING PROBABILITY VALUES WERE FOUND. C SET THE ENTIRE DOMAIN TO MISSING IN THIS CASE. C IF (IPRBCHECK.EQ.0) GOTO 900 IF (NERRFLG.NE.0) GOTO 900 C C PERFORM VALIDITY CK ON SUMMED PROB TYPE WTS FOR EACH REGION. C IPWTERR=0 DO NR=1,NUMREG DO K=1,NSTA IF(WPRBSUM(K,NR).NE.1.0.AND.WPRBSUM(K,NR).NE.0.0) THEN IPWTERR=IPWTERR+1 ENDIF ENDDO ENDDO IF(IPWTERR.NE.0) THEN WRITE(KFILDO,450) NDATE,ID,IPWTERR 450 FORMAT(/,' IN RAP_1HCNVPP NDATE, ID, IPWTERR = ',I10,2X, 1 4I10.9,I8,' INSTEAD IPWTERR SHOULD BE 0 ...SET ' 2 'DATA TO MISSING') GOTO 900 ENDIF C C LIMIT THE PROB RANGE TO 0.0 - 1.0. C DO K=1,NSTA IF(SDATA(K).LT.0.0) SDATA(K)=0.0 IF(SDATA(K).GT.1.0) SDATA(K)=1.0 ENDDO C C PUT SDATA( ) INTO GRD1( , ) FOR LIGHT SMOOTHING OF PROBS C DO K=1,NSTA GRD1(IX(K),JY(K))=SDATA(K) END DO C C APPLY LIGHT SPATIAL SMOOTHING (9 POINTS) TO PROB GRID. C SMOOTHING WT IS A FUNCTION OF PROJECTION. C NPROJ=IDPARS(12) CALL SMTH9VW(GRD1,NX,NY,WTSPSM(NPROJ),GRD2,9998.5,1) C C SMOOTHING FINISHED. MOVE PROBS BACK TO SDATA( ). C DO K=1,NSTA SDATA(K)=GRD1(IX(K),JY(K)) END DO C ISTAV=1 ISTAB=1 IER=0 GOTO 999 C 800 IER=47 WRITE(KFILDO,810) IER 810 FORMAT(/,'**** IN RAP_1HCNVPP ERROR IN CONVERSION OF FCST', 1 ' PTS. SET IER TO ',I3,' AND RETURN MISSING VALUES.') C 900 DO K=1,NSTA SDATA(K)=9999.0 END DO C 999 RETURN END