SUBROUTINE BCMAP_LAMP(KDATA,ND1,NUMPRJ,NSTA,ID) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: BCMAP MAPS MOS CATEGORIES TO BUFR CATEGORIES C PRGMMR: WEISS ORG: W/OSD211 DATE: 01-03-21 C C ABSTRACT: MAPS (TRANSLATES) MOS CATEGORICAL FORECAST VALUES TO THE C CORRESPONDING BUFR CODE TABLE VALUES. C C PROGRAM HISTORY LOG: C 93-12-03 GILBERT C 01-01-31 WEISS REVISED FOR MODIFIED BUFRMOS C 01-03-14 WEISS UPDATED IDS FOR THE AVN SHORT RANGE MESSAGE C 01-03-21 WEISS UPDATED IDS AND TRANSLATIONS FOR THE MRF C MEDIUM RANGE MESSAGE C 02-01-02 RLC ADDED MAPPING FOR AVN OBVIS CATEGORICAL FCSTS C CORRECTED AVN QPF CATEGORICAL IDS C 03-07-30 RLC CHANGED MRF FORECAST IDS FROM MODEL NUMBER C 9 TO 8 FOR GFS TRANSITION C 04-09-03 MALONEY CHANGED AVN REFERENCES TO GFS; ADDED LOOPS C TO HANDLE NEW CEILING AND VISIBILITY CATS; C ADDED PROCESSING FOR NEW GFS/ETA SNOWFALL; C ADDED IDS TO ALLOW ETA MOS PROCESSING. C 05-08-04 MALONEY MADE CHANGES TO NEW VISIBILITY MAPPING C 05-12-15 WEISS CONVERTED TO BUFRLAMP AND RENAMED BCMAP_LAMP C 06-05-09 WEISS TOOK OUT ELSEIF STATEMENT WHEN LAMP CATEGORICAL C PRODUCTS ARE GREATER THAN 2 SET TO 3. C 06-05-10 WIEDENFELD CLEANUP UP CODE. C 06-05-10 WIEDENFELD CHANGED 208643005 TO 208666005 FOR DIFFERENT C LAMP AND MOS PCHAR ID'S C 11-11-12 WEISS CHANGED 208351005 TO 208381005: TOTAL SKY COVER C TO OPAQUE SKY COVER C 14-03-27 HUANG COMMENTED OUT PROCESS FOR TSTM CAT (207501005) C BECAUSE IN THE NEW SYSTEM THIS WAS ALREADY PACKED C AS 0 AND 1 INSTEAD OF 1 AND 2. C 17-04-05 SCHNAPP ADDED IDS 208071035 AND 208131035 FOR MELD CIG AND C VIS C 20-03-19 HUANG CHANGED 208381005 TO 208381035: MELD SKY COVER C 20-07-19 HUANG CHANGED 208056005 TO 208056035 FOR MELD CCIG AND C 208156005 TO 208156035 FOR MELD CVIS C C USAGE: C MARCH 2001 WEISS IBM SP C C PURPOSE C MAPS (TRANSLATES) MOS CATEGORICAL FORECAST VALUES TO THE C CORRESPONDING BUFR CODE TABLE VALUES. C C DATA SET USE C NONE C C VARIABLES C KDATA(N,L) = HOLDS DATA FOR A FORECAST ELEMENT FOR EACH C STATION AND EACH PROJECTION. 1ST DIMENSION IS C # OF STATIONS, AND 2ND DIMENSION IS NUMBER OF C PROJECTIONS. CONTAINS MISSING "9999" FOR C PROJECTION FOR WHICH FORECASTS ARE NOT VALID. C N=1,ND1, L=1,NUMPRJ (INPUT/OUTPUT). C ND1 = MAXIMUM NUMBER OF STATIONS (INPUT). C NUMPRJ = NUMBER OF PROJECTIONS IN MESSAGE (INPUT). C NSTA = NUMBER OF STATIONS (INPUT). C ID(4) = MOS FORECAST IDENTIFIER (INPUT). C C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION C C ATTRIBUTES: C LANGUAGE: FORTRAN 90 C MACHINE: IBM SP C C$$$ IMPLICIT NONE C INTEGER KDATA(ND1,NUMPRJ),ND1,NUMPRJ,NSTA,ID(4) INTEGER I,J C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C CCC MAP CATEGORICAL VALUES CLOUD AMT C GFS/ETA: SHORT RANGE *NEW* IF(ID(1).EQ.208381035) THEN DO 190 I=1,NSTA DO 180 J=1,NUMPRJ IF (KDATA(I,J).EQ.1) THEN KDATA(I,J)=0 ELSEIF (KDATA(I,J).EQ.2) THEN KDATA(I,J)=13 ELSEIF (KDATA(I,J).EQ.3) THEN KDATA(I,J)=11 ELSEIF (KDATA(I,J).EQ.4) THEN KDATA(I,J)=12 ELSEIF (KDATA(I,J).EQ.5) THEN KDATA(I,J)=8 ENDIF 180 CONTINUE 190 CONTINUE C CCC MAP CATEGORICAL CONDITIONAL POP C GFS/ETA: SHORT RANGE *NEW* ELSEIF (ID(1).EQ.208666005) THEN DO 195 I=1,NSTA DO 185 J=1,NUMPRJ IF (KDATA(I,J).EQ.1) THEN KDATA(I,J)=3 ELSEIF (KDATA(I,J).EQ.2) THEN KDATA(I,J)=1 ELSEIF (KDATA(I,J).EQ.3) THEN KDATA(I,J)=2 ENDIF 185 CONTINUE 195 CONTINUE C CCC MAP CATEGORICAL VALUES POPO CCC MAP CATEGORICAL VALUES THUNDERSTORMS C GFS/ETA: SHORT RANGE *NEW* C C CH - ON MAR. 27, 2014, COMMENTED OUT C PROCESS FOR 207501005 BECAUSE IN THE C NEW CNV/LTG SYSTEM TSTM CAT WAS ALREADY C PACKED AS 0 AND 1. C C ELSEIF ((ID(1).EQ.208621005).OR. C 1 (ID(1).EQ.207501005)) THEN C ELSEIF (ID(1).EQ.208621005) THEN DO 210 I=1,NSTA DO 200 J=1,NUMPRJ IF (KDATA(I,J).EQ.1) THEN KDATA(I,J)=0 ELSEIF (KDATA(I,J).EQ.2) THEN KDATA(I,J)=1 ENDIF 200 CONTINUE 210 CONTINUE C C CCC MAP CATEGORICAL VALUES OBSTRUCTION TO VISION C GFS: SHORT RANGE ELSEIF (ID(1).EQ.208291005) THEN DO 230 I=1,NSTA DO 220 J=1,NUMPRJ IF (KDATA(I,J).EQ.1) THEN KDATA(I,J)=4 ELSEIF (KDATA(I,J).EQ.2) THEN KDATA(I,J)=2 ELSEIF (KDATA(I,J).EQ.3) THEN KDATA(I,J)=5 ELSEIF (KDATA(I,J).EQ.4) THEN KDATA(I,J)=3 ELSEIF (KDATA(I,J).EQ.5) THEN KDATA(I,J)=1 ENDIF 220 CONTINUE 230 CONTINUE C CCC MAP CATEGORICAL CEILING HGT C GFS/ETA (NEW!) ELSEIF (ID(1).EQ.208071005.OR.ID(1).EQ.208071035) THEN DO 235 I=1,NSTA DO 225 J=1,NUMPRJ IF (KDATA(I,J).EQ.1) THEN KDATA(I,J)=1 ELSEIF (KDATA(I,J).EQ.2) THEN KDATA(I,J)=2 ELSEIF (KDATA(I,J).EQ.3) THEN KDATA(I,J)=3 ELSEIF (KDATA(I,J).EQ.4) THEN KDATA(I,J)=8 ELSEIF (KDATA(I,J).EQ.5) THEN KDATA(I,J)=9 ELSEIF (KDATA(I,J).EQ.6) THEN KDATA(I,J)=5 ELSEIF (KDATA(I,J).EQ.7) THEN KDATA(I,J)=6 ELSEIF (KDATA(I,J).EQ.8) THEN KDATA(I,J)=7 ENDIF 225 CONTINUE 235 CONTINUE C CCC MAP CATEGORICAL CONDITIONAL CEILING HGT C GFS/ETA (NEW!) ELSEIF (ID(1).EQ.208056035) THEN DO 238 I=1,NSTA DO 228 J=1,NUMPRJ IF (KDATA(I,J).EQ.1) THEN KDATA(I,J)=1 ELSEIF (KDATA(I,J).EQ.2) THEN KDATA(I,J)=2 ELSEIF (KDATA(I,J).EQ.3) THEN KDATA(I,J)=3 ELSEIF (KDATA(I,J).EQ.4) THEN KDATA(I,J)=8 ELSEIF (KDATA(I,J).EQ.5) THEN KDATA(I,J)=9 ELSEIF (KDATA(I,J).EQ.6) THEN KDATA(I,J)=5 ELSEIF (KDATA(I,J).EQ.7) THEN KDATA(I,J)=6 ELSEIF (KDATA(I,J).EQ.8) THEN KDATA(I,J)=7 ENDIF 228 CONTINUE 238 CONTINUE C CCC MAP CATEGORICAL VISIBILITY C GFS/ETA (NEW!) ELSEIF (ID(1).EQ.208131005.OR.ID(1).EQ.208131035) THEN DO 250 I=1,NSTA DO 240 J=1,NUMPRJ IF (KDATA(I,J).EQ.1) THEN KDATA(I,J)=8 ELSEIF (KDATA(I,J).EQ.2) THEN KDATA(I,J)=9 ELSEIF (KDATA(I,J).EQ.3) THEN KDATA(I,J)=10 ELSEIF (KDATA(I,J).EQ.4) THEN KDATA(I,J)=11 ELSEIF (KDATA(I,J).EQ.5) THEN KDATA(I,J)=5 ELSEIF (KDATA(I,J).EQ.6) THEN KDATA(I,J)=6 ELSEIF (KDATA(I,J).EQ.7) THEN KDATA(I,J)=7 ENDIF 240 CONTINUE 250 CONTINUE C CCC MAP CATEGORICAL CONDITIONAL VISIBILITY C GFS/ETA (NEW!) ELSEIF (ID(1).EQ.208156035) THEN DO 270 I=1,NSTA DO 260 J=1,NUMPRJ IF (KDATA(I,J).EQ.1) THEN KDATA(I,J)=8 ELSEIF (KDATA(I,J).EQ.2) THEN KDATA(I,J)=9 ELSEIF (KDATA(I,J).EQ.3) THEN KDATA(I,J)=10 ELSEIF (KDATA(I,J).EQ.4) THEN KDATA(I,J)=11 ELSEIF (KDATA(I,J).EQ.5) THEN KDATA(I,J)=5 ELSEIF (KDATA(I,J).EQ.6) THEN KDATA(I,J)=6 ELSEIF (KDATA(I,J).EQ.7) THEN KDATA(I,J)=7 ENDIF 260 CONTINUE 270 CONTINUE ENDIF C RETURN END