SUBROUTINE AFMDC3(VERTIC,NODES,ZD,ZT,IRETN) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: AFMDC3 GENERATE AFOS RELATIVE VECTORS C PRGMMR: LUKE LIN ORG: W/NMC41 DATE: 97-01-08 C C ABSTRACT: GENERATE AFOS RELATIVE VECTORS ON AFOS GRAPHIC PRODUCT. C C PROGRAM HISTORY LOG: C 94-04-08 ORIGINAL AUTHOR LUKE LIN. C 94-06-30 HENRICHSEN ADDED LOGIC TO REMOVE FILLER CHARACTER. C CHANGED METHOD OF INCREMENTING THE BYTE C "ICNTOT" TO INCREMENT AND THEN LOAD. C 94-12-30 LUKE LIN CONVERT IT CFT-77. C 97-01-08 LUKE LIN MODIFY FOR STAIGHT FORWARD INPUT. c 98-06-19 chris caruso - extend common ispaceaf to equal length c of that common in s/r iniafbin C C USAGE: CALL AFMDC3(VERTIC,NODES,ZD,ZT,IRETN) C INPUT ARGUMENT LIST: C VERTIC - INTEGER ARRAY CONTAINS CONTOUR VECTORS. C NODES - NUMBER OF VERTICS. C ZD - INTEGER*4 .. FOR ZOOM DISABLE C =0, WHEN ZOOM IN, IT WILL BE EXTENDED BY THE ZOOM-FACTOR. C =1, WHEN ZOOM IN, IT WILL REMAIN AT THE BASIC PRODUCT C ZOOM ISZE AS DETERMINED BY ZOOM FACTOR. C ZT - INTEGER VALUE FOR ZOOM THRESHOLD OF TEXT. C - MAY HAVE THE FOLLOWING VALUES: C - ZT = 0, DISPLAY AT ALL ZOOMS. C - ZT = 1, DISPLAY AT ZOOMS 4 AND ABOVE. C - ZT = 2, DISPLAY AT ZOOMS 9 AND ABOVE. C - ZT = 3, DISPLAY AT ZOOMS 16 AND ABOVE. C COMMON - /ISPACE/LBLOCK,ICNTOT,LBNKFG C C OUTPUT ARGUMENT LIST: C IRETN - =0, NOMAL C =5, EXCEED THE ISPACE. C =12, DELTAS TOO LARGE FOR 12 BITS C COMMON - /ISPACE/LBLOCK,ICNTOT,LBNKFG C C REMARKS: C C ATTRIBUTES: C LANGUAGE: Cray fortran 90 C MACHINE: CRAY C C$$$ C COMMON /ISPACEAF/LBLOCK,ICNTOT,LBNKFG,lword4,maxcnt,ndsrn, * idum1,idum2,idum3,idum4,idum5 CHARACTER*1 LBLOCK(16384) integer icntot integer lbnkfg integer lword4 integer maxcnt integer ndsrn integer idum1,idum2,idum3,idum4,idum5 C INTEGER VERTIC(*) C INTEGER ZD, ZT INTEGER MODEHD INTEGER MODE INTEGER ILONG CHARACTER*2 CSHORT INTEGER MSK3F INTEGER MSKFFF INTEGER BB INTEGER B6 INTEGER B12 INTEGER IBEGIN C CHARACTER*2 CMEDIA C DATA MODEHD /Z'C300' / DATA MSK3F /Z'0000003F' / DATA MSKFFF /Z'00000FFF' / DATA B6 / 63 / DATA B12 / 4095 / save C C ....... START ..... C IRETN = 0 ITOT = ICNTOT + 8 + NODES ISAVE = ICNTOT IF (ITOT .GT. 16384) THEN IRETN = 5 WRITE(6,FMT='('' AFMDC3: ERROR, THE PRODUCT IS TOO BIG'')') RETURN ENDIF C C ..... SET THE ZOOM THRESHOLD ...... C MODE = MODEHD IF(ZT.GE.0 .AND. ZT.LE.3) THEN C C . . . TURN ON THE ZOOM THRESHOLD BITS AS REQUIRED. C IF (ZT .EQ. 1) THEN MODE = IBSET(MODE,3) elseif (ZT .EQ. 2) THEN MODE = IBSET(MODE,4) elseif (ZT .EQ. 3) THEN MODE = IBSET(MODE,3) MODE = IBSET(MODE,4) ENDIF ENDIF C C .... SET THE ZOOM-DISABLE BIT C IF (ZD .EQ. 1) THEN MODE = IBSET(MODE,5) ENDIF C C .... LOAD THE LAST TWO-BYTES .... C CALL SBYTES(CMEDIA,MODE,0,16,0,1) DO II = 1,2 ICNTOT = ICNTOT + 1 LBLOCK(ICNTOT) = CMEDIA(II:II) ENDDO C IXOLD = VERTIC(1) IYOLD = VERTIC(2) C IF (IXOLD .LE. 0 ) IXOLD = 1 IF (IYOLD .LE. 0 ) IYOLD = 1 IF (IXOLD .GT. 2047 ) IXOLD = 2047 IF (IYOLD .GT. 1535 ) IYOLD = 1535 C C .... LOAD I COORDINATE... C CALL SBYTES(CMEDIA,IXOLD,0,16,0,1) DO II = 1,2 ICNTOT = ICNTOT + 1 LBLOCK(ICNTOT) = CMEDIA(II:II) ENDDO C C .... LOAD J COORDINATE... C CALL SBYTES(CMEDIA,IYOLD,0,16,0,1) DO II = 1,2 ICNTOT = ICNTOT + 1 LBLOCK(ICNTOT) = CMEDIA(II:II) ENDDO IDXSAV = ICNTOT ICNTOT = ICNTOT + 2 NOWORD = 0 BB = 0 C C .... PROCESS EACH DELTA AND PUT OUT ONE OR TWO WORDS C DO 500 IDX = 2, NODES IXNEW = VERTIC(IDX*2 -1) IYNEW = VERTIC(IDX*2) IF (IXNEW .GE. 2048 ) IXNEW = 2047 IF (IXNEW .LE. 0) IXNEW = 1 IF (IYNEW .LE. 0) IYNEW = 1 IXDEL = IXNEW - IXOLD IYDEL = IYNEW - IYOLD C PRINT *, ' FOLLOWS :', IXNEW, IYNEW, IXDEL,IYDEL IF (IXDEL.EQ.0 .AND. IYDEL.EQ.0) GO TO 500 C C ....COMPUTE 2'S COMPLEMENT FOR NEGATIVE NUMBERS C IF ((IABS(IXDEL) .LE. B6) .AND. (IABS(IYDEL).LE.B6)) THEN C C ....DELTAS WILL FIT INTO ONE WORD.... C IF (IXDEL .LT. 0) THEN IXX = 64 - IABS(IXDEL) ELSE IXX = IXDEL ENDIF IF (IYDEL .LT. 0) THEN IYY = 64 - IABS(IYDEL) ELSE IYY = IYDEL ENDIF C C ..... LOAD DELX AND DELY C ILONG = 0 ILONG = IBSET(ILONG,15) ILONG = IOR(ILONG,ISHFT(IAND(IXX,MSK3F),8)) ILONG = IOR(ILONG,IAND(IYY,MSK3F)) IF (IXDEL .LT. 0) ILONG = IBSET(ILONG,14) IF (IYDEL .LT. 0) ILONG = IBSET(ILONG,6) CALL SBYTES(CSHORT,ILONG,0,16,0,1) DO II = 1,2 ICNTOT = ICNTOT + 1 LBLOCK(ICNTOT) = CSHORT(II:II) ENDDO NOWORD = NOWORD + 1 elseif ((IABS(IXDEL) .LE. B12) .AND. & (IABS(IYDEL).LE.B12)) THEN C C ....DELTAS GO IN TWO WORDS .... C IF (IXDEL .LT. 0) THEN IXX = 4096 - IABS(IXDEL) ELSE IXX = IXDEL ENDIF IF (IYDEL .LT. 0) THEN IYY = 4096 - IABS(IYDEL) ELSE IYY = IYDEL ENDIF C C ..... LOAD DELX AND DELY C C PRINT *, ' ***** LOAD A TWO BYTES DELX/Y' ILONG = 0 ILONG = IOR(ILONG,IAND(IABS(IXX),MSKFFF)) IF (IXDEL .LT. 0) ILONG = IBSET(ILONG,12) CALL SBYTES(CSHORT,ILONG,0,16,0,1) DO II = 1,2 ICNTOT = ICNTOT + 1 LBLOCK(ICNTOT) = CSHORT(II:II) ENDDO ILONG = 0 ILONG = IOR(ILONG,IAND(IABS(IYY),MSKFFF)) IF (IYDEL .LT. 0) ILONG = IBSET(ILONG,12) CALL SBYTES(CSHORT,ILONG,0,16,0,1) DO II = 1,2 ICNTOT = ICNTOT + 1 LBLOCK(ICNTOT) = CSHORT(II:II) ENDDO NOWORD = NOWORD + 2 ELSE PRINT *,' DELTAS ARE TOO LARGE FOR 12 BITS ' IRETN = 12 ICNTOT = ISAVE RETURN ENDIF 500 CONTINUE C C ... LOAD NO OF WORDS FOLLOW .... C IF ( NOWORD .EQ. 0) THEN ICNTOT = ISAVE C C .... NOTHING IN THIS ENTRY C ELSE ILONG = NOWORD CALL SBYTES(CSHORT,ILONG,0,16,0,1) DO II = 1,2 IDXSAV = IDXSAV + 1 LBLOCK(IDXSAV) = CSHORT(II:II) ENDDO C INOBYE = 8 + NOWORD * 2 ENDIF RETURN END c********************************************************************* SUBROUTINE AFMDC8(INTEXT,NOCHAR,IX,IY,IDX,IDY, 1 B,RB,ZT,ISIZE,IRETN) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: AFMDC8 PUT OFFSET TEXT ON AFOS GRAPHICS. C PRGMMR: RICHARD WOBUS ORG: W/NP2 DATE: 97-08-14 C C ABSTRACT: PUTS OFFSET TEXT (MODE C8) ON AFOS GRAPHICS PRODUCTS. C THE TEXT IN ASCII IS PASSED IN INTEXT. C C PROGRAM HISTORY LOG: C 96-12-18 ORIGINAL AUTHOR LUKE LIN. c 97-08-14 ADD OFFSET MODE RICHARD WOBUS c 98-06-19 chris caruso - extend common ispaceaf to equal length c of that common in s/r iniafbin C C USAGE: CALL AFMDC8(INTEXT,NOCHAR,IX,IY,idx,idy, c 1 B,RB,ZT,ISIZE) C INPUT ARGUMENT LIST: C INTEXT - CHARACTER*1 ARRAY CONTAINING TEXT STRING IN HOLLERTH. C NOCHAR - NUMBER OF BYTES IN TEXT STRING. C IX,IY - THE X AND Y LOCATION FOR TEXT ON AFOS IN DOTS. c idx,idy - the delta x and y offset for text in dots. C B - BLOCK MODE. C RB - REVERSE BLOCK MODE. C ZT - INTEGER VALUE FOR ZOOM THRESHOLD OF TEXT. C - MAY HAVE THE FOLLOWING VALUES: C - ZT = 0, DISPLAY AT ALL ZOOMS. C - ZT = 1, DISPLAY AT ZOOMS 4 AND ABOVE. C - ZT = 2, DISPLAY AT ZOOMS 9 AND ABOVE. C - ZT = 3, DISPLAY AT ZOOMS 16 AND ABOVE. C ISIZE - IF = 0 USE STANDARD CHAR. SIZE. C - IF = 2, OR GREATER 2 DOUBLE TEXT SIZE. C COMMON - /ISPACE/LBLOCK,ICNTOT,LBNKFG C C OUTPUT ARGUMENT LIST: C IRETN - =0, NOMAL C =5, EXCEED THE ISPACE C =11, HIGH/LOW STRING ERROR C COMMON - /ISPACE/LBLOCK,ICNTOT,LBNKFG C LBLOCK - CHARACTER*1 16384 BYTE ARRAY THAT CONTAINS THE AFOS C - DATA IN UGF FORMAT. C ICNTOT - INTEGER*4 WORD THAT CONTAINS THE NUMBER OF BYTES IN C - LBLOCK ARRAY. C LBNKFG - INTEGER*4 FLAG WORD THAT TELLS IF A FILLER CHARATER C - WAS THE LAST BYTE IN LBLOCK ARRAY. C - =-1 THEN FILLER CHARATER. C - =0 THEN NO FILLER CHARATER. C C REMARKS: C WE SET ZLOW=2000 AND ZHIGH=2000 FROM COMMON BLOCK FOR TEXT STRING C THAT IN AFOS MAPS WILL BE A CENTER HIGH/LOW STRING C C ATTRIBUTES: C LANGUAGE: Cray fortran 90 C MACHINE: CRAY C C$$$ C COMMON /ISPACEAF/LBLOCK,ICNTOT,LBNKFG,lword4,maxcnt,ndsrn, * idum1,idum2,idum3,idum4,idum5 CHARACTER*1 LBLOCK(16384) integer icntot integer lbnkfg integer lword4 integer maxcnt integer ndsrn integer idum1,idum2,idum3,idum4,idum5 C INTEGER IX,IY,R,RB,ZT,ISIZE,idx,idy integer mskff INTEGER MODE C INTEGER MODEHD C CHARACTER*1 ABLANK CHARACTER*1 BIGHI CHARACTER*1 BIGLO CHARACTER*2 CMEDIA character*2 cshort CHARACTER*1 INTEXT(NOCHAR) CHARACTER*1 OUTEXT(256) INTEGER IOUTXT(2) EQUIVALENCE (IOUTXT(1),OUTEXT(1)) C DATA MODEHD /Z'C840'/ data mskff /z'000000ff'/ C save IF (IX .LE. 0 .OR. IX.GT.2048) RETURN IF (IY .LE. 0 .OR. IY.GT.1536) RETURN C ABLANK = CHAR(32) IF(LBNKFG.EQ.-1)THEN ICNTOT = ICNTOT - 1 LBNKFG = 0 ENDIF C IRETN = 0 ISAVE = ICNTOT ITOT = ICNTOT + 8 + NOCHAR NOCH = NOCHAR + 1 IF (ITOT .GT. 16384) THEN IRETN = 5 WRITE(6,FMT='('' AFMDC8: ERROR, THE PRODUCT IS TOO BIG!'')') RETURN ENDIF IF (ISIZE.GT.2) ISIZE = 2 C C CHECK TO SEE IF OFFSET MODE IS DESIRED......... C LOAD IN ZOOM THRESHOLD C MODE = MODEHD IF(ZT.GE.0 .AND. ZT.LE.3) THEN C C . . . TURN ON THE ZOOM THRESHOLD BITS AS REQUIRED. C IF (ZT .EQ. 1) THEN MODE = IBSET(MODE,3) C PRINT *,' GOT A ZOOM THRESHOLD 4:1' elseif (ZT .EQ. 2) THEN MODE = IBSET(MODE,4) C PRINT *,' GOT A ZOOM THRESHOLD 9:1' elseif (ZT .EQ. 3) THEN MODE = IBSET(MODE,3) MODE = IBSET(MODE,4) C PRINT *,' GOT A ZOOM THRESHOLD 16:1' ELSE C PRINT *,' GOT A ZOOM THRESHOLD 1:1' ENDIF ENDIF C C . . . CHECK TO SEE IF RESERVE BLOCK FLAG IS SET C IF( RB.EQ.1) MODE = IBSET(MODE,5) C C .... LOAD THE LAST TWO BYTES C CALL SBYTES(CMEDIA,MODE,0,16,0,1) DO II = 1,2 ICNTOT = ICNTOT + 1 LBLOCK(ICNTOT) = CMEDIA(II:II) ENDDO C DO I = 1, NOCHAR OUTEXT(I) = INTEXT(I) ENDDO c C .... LOAD I COORDINATE... c CALL SBYTES(CMEDIA,IX,0,16,0,1) DO II = 1,2 ICNTOT = ICNTOT + 1 LBLOCK(ICNTOT) = CMEDIA(II:II) ENDDO c C .... LOAD J COORDINATE... c CALL SBYTES(CMEDIA,IY,0,16,0,1) DO II = 1,2 ICNTOT = ICNTOT + 1 LBLOCK(ICNTOT) = CMEDIA(II:II) ENDDO C ..... LOAD DELX AND DELY c ILONG = 0 ILONG = IOR(ILONG,ISHFT(IAND(IDX,MSKFF),8)) ILONG = IOR(ILONG,IAND(IDY,MSKFF)) CALL SBYTES(CSHORT,ILONG,0,16,0,1) DO II = 1,2 ICNTOT = ICNTOT + 1 LBLOCK(ICNTOT) = CSHORT(II:II) ENDDO C C . . . MOVE TEXT FROM IOUTXT TO LBLOCK.... C DO I = 1, NOCHAR ICNTOT = ICNTOT +1 LBLOCK(ICNTOT) = INTEXT(I) ENDDO C C . . . CHECK TO SEE IF NOCHAR IS EVEN..... C IREM = MOD(NOCHAR,2) c C . . . CALCULATE NUMBER OF HALF WORDS.... c IF(IREM.EQ.1) THEN ICNTOT = ICNTOT + 1 LBLOCK(ICNTOT) = ABLANK LBNKFG = - 1 ENDIF C print *, ' end of afmdc8, icntot=', icntot RETURN END c********************************************************************* SUBROUTINE AFSLGD C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: AFSLGD PUT LEGEND FOR AFOS AUTOMATIC STATION. C PRGMMR: LUKE LIN ORG: W/NMC41 DATE: 92-12-22 C C ABSTRACT: THIS SUBR WILL PUT LEGEND ON AFOS GRAPHICS PRODUCTS. C THE AUTOMATIC STATION WILL HAVE RIGHT BRACKET AFTER STATION CIRCLE. C C PROGRAM HISTORY LOG: C 92-12-22 ORIGINAL AUTHOR LUKE LIN C C USAGE: CALL AFSLGD C INPUT ARGUMENT LIST: C ARGUMT - C C OUTPUT FILES: C FT06F001 - PRINTFILE. C OUTPUT COMMON C C COMMON/ISPACE/LBLOCK,LCNTOT,MCNTOT C C REMARKS: NONE C C ATTRIBUTES: C LANGUAGE: FORTRAN 90 C MACHINE: cray C C$$$ C C . . . THIS SUBR WILL PUT TEXT OR TITLES ON AFOS PRODUCTS.. C CHARACTER*25 L1 integer il1(4) equivalence (l1,il1(1)) data iL1 / x'11126B6B6B6B6B6B', x x'6B6B6B6B6B6B6B6B', x x'6B6B6B6B6B6B6B6B', x x'1100000000000000' / CHARACTER*30 L2 integer il2(4) equivalence (l2,il2(1)) data iL2 / x'1239090E31112049', x x'53204155544F4D41', x x'544943205758204F', x x'4253201238110000' / logical MOBLOK logical MOREVB logical ISEBCD logical MOFFAN save C MOBLOK = .FALSE. MOREVB = .FALSE. MOFFAN = .FALSE. ISEBCD = .FALSE. IRETN = 0 IFLAG = 0 ix = 100 jy = 310 kx = 106 - ix ly = 296 - jy call afmdc8(l1,25,ix,jy,kx,ly,moblok,morevb,0,0,iretn) ix = 100 jy = 310 call afmdc5(l2,30,ix,jy, moblok,morevb,0,0,iretn) kx = 106 - ix ly = 325 - jy call afmdc8(l1,25,ix,jy,kx,ly,moblok,morevb,0,0,iretn) RETURN enD c********************************************************************* LOGICAL FUNCTION BSIR(NAME,RSATBL,MXTBL,c8RES,IRETN) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: BSIR BINARY SEARCH FUNCTION C PRGMMR: WOBUS ORG: W/NP20 DATE: 97-01-24 C C ABSTRACT: TO SEARCH THRU THE GIVEN LOOK-UP TABLE FOR A MATCHING C 4-LETTER STATION NAME. THIS IS CALLED FROM CALLTR() IN THE C WEATHER DEPICTION PROGRAM. C C PROGRAM HISTORY LOG: C 92-09-18 ORIGINAL AUTHOR(S)'S NAME: SHIMOMURA C 97-01-24 RICHARD WOBUS - CONVERT TO CRAY c 98-06-08 chris caruso - remove cdir$ integer=64 from top of c this s/r C C USAGE: IF( BSIR(NAME, RSATBL, MXTBL, I4RES, IRETN) )THEN C INPUT ARGUMENT LIST: C NAME - C*4 NAME ... THE NAME FOR WHICH A MATCH WILL BE SOUGHT C RSATBL - R*8 RSATBL(MXTBL) ... THIS IS THE LOOK-UP TABLE IN C WHICH EACH ITEM IS 8 BYTES, IN WHICH THE FIRST 4 BYTES C IS A C*4 NAME AND THE SECOND 4 BYTES CAN BE CONSIDERED C TO BE AN I*4 BINARY INTEGER OF INFORMATION ABOUT THAT C ITEM. IN THE CASE WHERE THIS ITEM MATCHES, THEN THIS C SECOND 4 BYTES IS WHAT IS RETURNED AS THE RESULT. C MXTBL - I*4 DIMENSION OF RSATBL() C C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) Cc I4RES - I*4 I4RES ... FOR THE RESULTS. IF A MATCHING NAME Cc IS FOUND, THEN THE SECOND 4 BYTES OF THE RSATBL() Cc IS MOVED INTO I4RES. C C8RES - C*8 c8RES ... FOR THE RESULTS. IF A MATCHING NAME C IS FOUND, THEN THE last 8 BYTES OF THE RSATBL() C IS MOVED INTO c8RES. C IRETN - I*4 IRETN ... THE RETURN CODE. C - FOR NORMAL RETURN, IRETN CONTAINS A POSITIVE-VALUED C NUMBER WHICH IS THE SUBSCRIPT IN THE RSATBL() FOR C THE FOUND MATCH C - ZERO OR NEGATIVE-VALUED ARE FOR FAILED TO FIND A MATCH C = 0 IF GIVEN NAME WAS ALL BLANKS C =-2 IF BAD MXTBL ARG (DIMENSION OF TABLE) WAS GIVEN C =-3 IF GIVEN NAME HAD ZERO LENGTH C (CALLER HAS NOT DEFINED THE NAME AS CHAR*4) C BSIR - THE logical FUNCTION VALUE IS C .TRUE. IF MATCH WAS FOUND; C .FALSE. IF FAILED TO FIND A MATCH IN THE TABLE C C C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION C THE GIVEN TABLE ENTRIES MUST IN ALPHABETIC ORDER BY THE EBCDIC C COLLATING SEQUENCE ... NUMERALS COME LATER THAN LETTERS IN EBCDIC C C ATTRIBUTES: C LANGUAGE: cray fortran 90 C MACHINE: CRAY4 C C$$$ C COPIED [006300.CNTR]IBSIRCH.FOR 18-SEP-1992/DSS C ... TO STRIP IT DOWN AND UN-GENERALIZE TO FIT THE WX DEPIC C ... TABLE SEARCH IN CALLTR() C CHARACTER*4 NAME INTEGER MXTBL character*12 RSATBL(MXTBL) character*8 c8res INTEGER IRETN C . . . . . . . . . . . . . . character*12 rsattt C logical LASTLP logical LOFFRT logical LOFFLW save C iwrite = 0 if (name.eq.'CWAE') iwrite = 1 if (name.eq.'CWAN') iwrite = 1 if (name.eq.'KE74') iwrite = 1 if (name.eq.'KEWB') iwrite = 1 if (name.eq.'KSAV') iwrite = 1 if (name.eq.'KSLN') iwrite = 1 if (name.eq.'KSMN') iwrite = 1 if (name.eq.'MYGW') iwrite = 1 if (name.eq.'MYNN') iwrite = 1 BSIR = .FALSE. IRETN = 0 MDIS = 0 IF(MXTBL .LE. 0) GO TO 920 IF(LEN(NAME) .LE. 0) GO TO 930 IF(NAME(1:4) .EQ. ' ') GO TO 900 C C ================================================================= C 300 CONTINUE C C ... COMES HERE TO DO BINARY SEARCH ON TABLE ... C IBEGIN = 1 MIDPT = (MXTBL/2) + 1 INCR = MIDPT II = 0 LASTLP = .FALSE. LOFFRT = .FALSE. LOFFLW = .FALSE. 330 CONTINUE if (iwrite.eq.1) then write(6,'('' in bsir: MDIS,MIDPT,INCR,NAME,LASTLP,LOFFRT,'', 1 ''LOFFLW'',3i5,1x,a4,1x,3l2)') 2 mdis,midpt,incr,name,lastlp,loffrt,lofflw endif II = II + 1 IF(INCR .LE. 1) LASTLP = .TRUE. C C ... OTHERWISE, WE ARE NOT DOWN TO SINGLE STEP OF FINAL COMPARE C INCR = (INCR+1) / 2 IF(LOFFRT) GO TO 333 IF(LOFFLW) GO TO 344 MDIS = IBEGIN + MIDPT - 1 rsattt = RSATBL(MDIS) IF(NAME(1:4) .LT. rsattt(1:4)) THEN GO TO 333 elseif(NAME(1:4) .EQ. rsattt(1:4)) THEN C C ... FOUND EXACT MATCH, SO JUMP TO "FOUND" C GO TO 400 ELSE C C ... WAS .GT. ... C GO TO 344 ENDIF 333 CONTINUE LOFFRT = .FALSE. C C ... GO TO LOWER HALF AND BISECT IT ... C IF(LASTLP) GO TO 388 MIDPT = MIDPT - INCR IF(MIDPT .GT. 0) GO TO 330 C C ... OTHERWISE, SEARCH FELL BELOW LOWER END OF TABLE ... C ... SET SWITCH LOFFLW AND LET IT JUMP BACK INTO TABLE ... C 336 continue LOFFLW = .TRUE. GO TO 330 C 344 CONTINUE LOFFLW = .FALSE. C C ... GO TO UPPER HALF AND BISECT ... C IF (LASTLP) GO TO 388 MIDPT = MIDPT + INCR IF(MIDPT .LE. MXTBL) GO TO 330 C C ... OTHERWISE, SEARCH FELL BEYOND END OF TABLE ... C ... SET SWITCH LOFFRT AND LET IT JUMP BACK INTO TABLE C incr = incr+2 LOFFRT = .TRUE. GO TO 330 C 388 CONTINUE C C ... COMES TO 388 IF NO MATCH FOUND IN TABLE ... C if (midpt.gt.mxtbl) then C c do not end search with midpoint beyond end of table C midpt = mxtbl go to 330 endif if (midpt.le.0) then C c do not end search with midpoint beyond end of table C midpt = 1 go to 330 endif GO TO 900 C 400 CONTINUE C C ... COMES HERE IF MATCH WAS FOUND AT MDIS ... C IRETN = MDIS c8res = rsattt(5:12) BSIR = .TRUE. GO TO 999 C 900 CONTINUE IRETN = 0 GO TO 999 920 CONTINUE C C ... COMES HERE IF BAD MXTBL ARG (DIMENSION OF TABLE) WAS GIVEN C IRETN = -2 GO TO 999 930 CONTINUE C C ... COMES HERE IF GIVEN NAME HAD ZERO LENGTH C IRETN = -3 GO TO 999 C 999 CONTINUE RETURN END c********************************************************************* SUBROUTINE CALLTR(CINNAM,ISKEW,IPLPRI,LFOUND) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: CALLTR CHECK TO SEE IF STATION IS IN LOOKUP TABL C PRGMMR: WOBUS ORG: W/NP20 DATE: 97-01-24 C C ABSTRACT: GIVEN THE SURFACE HOURLY CALL LETTERS,DETERMINE IF C STATION IS IN WEATHER DEPICTION LOOK-UP TABLE. C C C PROGRAM HISTORY LOG: C 84-09-28 ORIGINAL AUTHOR HENRICHSEN C 91-09-11 HENRICHSEN ADD NEW DOCBLOCK. C 92-09-18 SHIMOMURA -- F77 CONVERSION C ADDED CALL TO L*4 FUNCTION BSIR C 97-01-24 RICHARD WOBUS - CONVERT TO CRAY c 98-06-08 chris caruso - remove cdir$ integer=64 from top of c this s/r C C USAGE: CALL CALLTR(CINNAM,ISKEW,IPLPRI,LFOUND) C INPUT ARGUMENT LIST: C CINNAM - THIS IS HOURLY STATION NAME IN CHARACTER*4. C INPUT VIA COMMON: C /WXPISA/ RSASTN,RSATBL(775) C RSASTN - REAL*8 DOUBLE WORD FIRST FOUR BYTES HAS INTEGER NUMBER C - OF STATIONS IN RSATBL. C RSATBL - REAL*8 RSATBL(775)DOUBLE WORD ARRAY C - WHERE EACH DOUBLE WORD HAS THIS FORMAT: C - FIRST FOUR BYTES CONTAIN NAME OF STATION IN HOLLERTH. C - BYTES 5 & 6 CONTAIN SKEW CODE IN INTEGER. C - BYTES 7 & 8 CONTAIN PLOTTING PRIORITY IN INTEGER. C C OUTPUT ARGUMENT LIST: C ISKEW - SKEW CODE FOR MOVG ITEMS AROUND PLOTTING MODEL. C IPLPRI - PLOTTING PRIORITY. C LFOUND - SET = .TRUE. IF STN FOUND IN TABLE C C OUTPUT FILES: C DDNAME2 - GENERIC NAME & CONTENT AS ABOVE C FT06F001 - PRINT FILE. C C REMARKS: IF STATION IS FOUND LFOUND IS SET TO .TRUE. C C ATTRIBUTES: C LANGUAGE: CRAY FORTRAN 90 C MACHINE: CRAY4 C C$$$ C C ... THE STATION TABLE IS PREDEFINED IN LABELLED COMMON /WXPISA/ C ... BY ASSEMBLY-LANGUAGE MODULE ... COMMON /WXPISA/ RSASTN,RSATBL(2700) integer rsastn character*12 rsatbl C C (1) (2) (3) (4) C ... ARGS TO CALLTR (CINNAM,ISKEW,IPLPRI,LFOUND) C CHARACTER*4 CINNAM INTEGER ISKEW INTEGER IPLPRI LOGICAL LFOUND C . . . . . . . . . . . . . . . . . LOGICAL BSIR C ... WHICH DECLARES THE L*4 FUNCTION SUBPROGRAM BSIR() C ... WHICH IS THE BINARY SEARCH ROUTINE ... C INTEGER MXTBL character*8 c8res INTEGER IRETN C integer kount data kount /0/ save C C . . . . . . . . . . . . . . . . . C LFOUND = .FALSE. mxtbl = rsastn ISKEW = 0 IPLPRI = 0 C C ... SEARCH STATION TABLE FOR MATCHING STATION NAME............. C IF(BSIR(CINNAM,RSATBL,MXTBL,c8RES,IRETN)) THEN LFOUND = .TRUE. kount = kount + 1 iwrite = 0 if (cinnam.eq.'CWAE') iwrite = 1 if (cinnam.eq.'CWAN') iwrite = 1 if (cinnam.eq.'KE74') iwrite = 1 if (cinnam.eq.'KEWB') iwrite = 1 if (cinnam.eq.'KSAV') iwrite = 1 if (cinnam.eq.'KSLN') iwrite = 1 if (cinnam.eq.'KSMN') iwrite = 1 if (cinnam.eq.'MYGW') iwrite = 1 if (cinnam.eq.'MYNN') iwrite = 1 if (iwrite.eq.1) then if (mod(kount,20).eq.1) then write(6,'('' in calltr: cinnam,mxtbl,c8res,iretn,lfound'', 1 1x,a4,i5,1x,a8,i5,1x,l1)')cinnam,mxtbl,c8res,iretn,lfound endif endif read(c8res,'(1x,i3,1x,i3)') ISKEW,iplpri ENDIF C RETURN END c********************************************************************* subroutine rtfill C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: RTFILL READS THE STATION TABLE AND FILLS ARRAY C PRGMMR: RICHARD WOBUS ORG: W/NP2 DATE: 98-02-26 C C ABSTRACT: This program reads the station table into a common c block for use by the weather depiction plotting code. The c format of the table is described below. C C PROGRAM HISTORY LOG: C 98-02-26 RICHARD WOBUS - CREATE THIS DOCBLOCK c 98-06-08 chris caruso - remove cdir$ integer=64 from top of c this s/r C C USAGE: CALL RTFILL C C INPUT FILES: C FT11F001 - STATION TABLE C C OUTPUT FILES: C FT06F001 - PRINTOUT C C COMMON BLOCKS: C WXPISA - STATION TABLE C C REMARKS: c c data is concatenated into a single character string for simplicity c c format of the station list: c c iiii www ppp a c c where c iiii = 4 character station identifier, starting in column 1 c c www = skew code (normally 0) = imovww*8 + imovht c c imovww specifies plot position for weather and visibility: c c present weather visibility c c 2 c 1 1 c 0 stn 024 stn c 3 3 c 4 c c imovht specifies plot position for cloud height: c c stn 2 c 3 1 c 0 c c ppp = izoomt*10 + iplpri c izoomt = zoom threshold for AFOS plotting (0,1,2,3) c or 4 if not to be plotted c c iplpri = plotting priority c 0 plot sky cover, cloud height, present wx, visibility c 1 plot present wx c 2 plot present wx only if thunderstorm or severe c 4 never plot c c a = active station marker: c a = active c i = inactive, found in recent station dictionaries c - = inactive, not found in recent station dictionaries c Many of these result from METAR conversion: c Station identifiers have been converted to METAR form. c Identifiers beginning with W-Z have been prefixed with c both C and K in the new list. Where one has been found c in a station dictionary, the other has been deleted, c but if neither is in a dictionary both are retained. c Inactive stations are kept in the list to preserve c their skew and priority settings in case they c become active again. c c c = comments, not read by rtfill c c the count of stations is maintained automatically by rtfill c c stations should be added in ASCII alphabetical order c (0-9 precede A-Z) c the order is checked but not corrected by rtfill c C ATTRIBUTES: C LANGUAGE: CRAy FORTRAN 90 C MACHINE: CRAY4 C C$$$ COMMON /WXPISA/ RSASTN,RSATBL(2700) integer rsastn character*12 rsatbl character*12 instr character*1 indic integer instnunit data instnunit/11/ save rsastn = 0 write(6,'('' in rtfill: begin'')') c c station list read from table in unit 11 c rsastn = 0 inact = 0 rewind instnunit do i = 1,12000 read(instnunit,'(a12,1x,a1)',end=4343,err=4342) * instr,indic if (indic.eq.'a') then if (rsastn.eq.2700) go to 4341 rsastn = rsastn + 1 rsatbl(rsastn) = instr else inact = inact + 1 endif enddo write(6,'('' in rtfill: did not process all stations'')') go to 4344 4341 continue write(6,'('' in rtfill: ran out of space for stations'')') go to 4344 4342 continue write(6,'('' in rtfill: read error '')') go to 4344 4343 continue write(6,'('' in rtfill: EOF '')') 4344 continue write(6,'('' in rtfill: stations active, inactive'',2i6)') 1 rsastn,inact c c check for sorted table c nstam = rsastn - 1 do i = 1,nstam j = i + 1 if (rsatbl(i)(1:4).ge.rsatbl(j)(1:4)) then write(6,'('' in rsatbl: items'',i4,1x,a12, 1 '' and'',i4,1x,a12,'' are out of order'')') 2 i,rsatbl(i),j,rsatbl(j) endif enddo write(6,'('' in rtfill:'',i6,'' stations placed in list'')') 1 rsastn return END c********************************************************************** SUBROUTINE STAPLT(IUNIT,IDOT,JDOT,IZOOMT,N,IHVSBY,IWW,IHCIGH, 1 NAMSTN,IPLOTQ,MFONSZ,LPRT,AUTOST,lchout) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: STAPLT AFOS PLOTTING-MODEL COMPOSER C PRGMMR: LUKE LIN ORG: W/NMC412 DATE: 93-01-06 C C ABSTRACT: GIVEN- ONE STATION'S METEOROLOGICAL QUANTITIES PRE-SELECTED C FOR THE WEATHER DEPICTION STATION MODEL; TASK - TO COMPOSE THE C PLOTTING MODEL FOR AFOS INTO ONE ASCII TEXT STRING USING THE AFOS C CHARACTER SETS WHICH INCLUDES CODES FOR SPECIAL SYMBOLS AND FOR C POSITIONING; CALLS Afmdc8 TO COMPLETE THE ENCODING INTO AFOS UGF. C C UNDER OPTION CONTROL (IF LPRT==.TRUE.) CAN GENERATE A METAFILE IN C 80-COL CARD FORMAT WHICH IS INPUT INTO AN AFOS SIMULATOR PROGRAM. C C PROGRAM HISTORY LOG: C 78-03-23 ORIGINAL AUTHOR PETER CARR C 78-05-30 GLORIA DENT TOOK OVER WHEN P.CARR LEFT -- ADDED ALFAR C 78-06-29 HENRICHSEN TOOK OVER FROM GLORIA C 78-07-31 HENRICHSEN PUT INTO OPNS C 84-05-11 HENRICHSEN C 91-09-11 HENRICHSEN ADD DOCBLOCK. C 92-07-03 SHIMOMURA: F77 CONVERSION C 93-01-06 LUKE LIN PLOT AUTO STAT. AND SOME SPECIAL WW c 98-06-08 chris caruso - remove cdir$ integer=64 from top of c this s/r C C USAGE: CALL STAPLT(IUNIT,IDOT,JDOT,IZOOMT,N,IHVSBY,IWW,IHCIGH, C 1 NAMSTN,IPLOTQ,MFONSZ,LPRT,autost,lchout) C INPUT ARGUMENT LIST: C IUNIT - I*4 DSRN FOR CHECKOUT OUTPUT OF SIMULATOR CARDS C IDOT - I*4 I-COORDINATE OF STN LOCATION (I5) C JDOT - I*4 J-COORDINATE OF STN LOCATION (I5) C IZOOMT - I*4 ZOOM THRESHOLD. CODE AS BINARY INTEGER. (I1) C N - I*4 SKY-COVER AS BINARY INTEGER = (0:10) C IHVSBY - C*4 VSBY IN EBCDIC C 1ST CHAR=UNIT, 2ND CHAR=NUMER, 3RD & 4TH CHAR=DENOM. C IWW - I*4 PRESENT WX CODE AS BINARY INTEGER = (0?:105) C IHCIGH - C*4 CEILING HGT IN EBDIC. C NAMSTN - C*8 STN NAME AS 8 EBDIC CHARACTERS. C IPLOTQ - I*4 BITS TO CONTROL WHICH PARAMETERS TO PLOT C MFONSZ - I*4 SOME MULTIPLICATIVE FOR FONT SIZE (I1) C LPRT - L*4 LOGICAL SWITCH TO REQUEST CHECKOUT SIMUL CARDS C AUTOST - L*4 LOGICAL IF TRUE, AN AUTOMATIC; OTHERWISE. c lchout - logical if true, print is on. C C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) C WRKARG - GENERIC DESCRIPTION, ETC., AS ABOVE. C OUTARG1 - EXPLAIN COMPLETELY IF ERROR RETURN C ERRFLAG - EVEN IF MANY LINES ARE NEEDED C C OUTPUT FILES: (DELETE IF NO OUTPUT FILES IN SUBPROGRAM) C FT06F001 - INCLUDE IF ANY PRINTOUT C C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION C C ATTRIBUTES: C LANGUAGE: FORTRAN 90 C MACHINE: cray C C$$$ C C ================================================================ C ... SINCE NOBODY REMEMBERS THE SIMULATOR ANYMORE, THAT LOGIC C ... SHOULD BE REMOVED ... C INTEGER MAXWKF PARAMETER (MAXWKF = 48 ) C ... WHERE MAXWKF IS MAX NO. OF CHARS IN LWORKF C C THE PRODUCT DEFINITION CONSTANTS COMMON /PRODUK/ PI,GS,PDC,ZD,ZT,ZFACT INTEGER PI,GS,PDC,ZD,ZT,ZFACT C C ... CALL SEQUENCE ARG LIST: c INTEGER IUNIT INTEGER IDOT,JDOT INTEGER IZOOMT INTEGER N c C ... WHERE N IS CLOUD AMOUNT AS BINARY INTEGER = (0:10) c CHARACTER*4 IHVSBY c C ... INTEGER*4 IHVSBY ... VISIBILITY - 'VVVV' c INTEGER IWW CHARACTER*4 IHCIGH CHARACTER*4 IHCIGc c C ... INTEGER*4 IHCIGH ... CEILING HGT - 'HHH' c CHARACTER*8 NAMSTN c C ... DIMENSION NAMSTN(2) ... STN NAME - 'NAME' c INTEGER IPLOTQ INTEGER MFONSZ logical LPRT logical AUTOST logical lchout c C . . . . . . . . . . . . . . . . . . . . . . . . . . . C DIMENSION MSK8TH(8) CHARACTER*1 CAHHH(4) CHARACTER*1 CAVSBY(4) CHARACTER*1 CNAME(6) INTEGER IALTER(12) INTEGER IACC INTEGER KNSKEL(6,6) C INTEGER ILSTR(14) CHARACTER*1 LSTR(200) EQUIVALENCE (ILSTR(1),LSTR(1)) C INTEGER MSTNCR(2) CHARACTER*1 KSTNCR(16) EQUIVALENCE (MSTNCR(1),KSTNCR(1)) C C . . . . . . . . . . . . . . . . . . . C INTEGER IWWTBL(103) CHARACTER*1 LWWTBL(8,103) EQUIVALENCE (LWWTBL(1,1),IWWTBL(1)) C CHARACTER*1 LWWTBM(8,91) EQUIVALENCE (LWWTBL(1,1),LWWTBM(1,1)) C CHARACTER*1 LWWTBK(8,12) EQUIVALENCE (LWWTBL(1,92),LWWTBK(1,1)) C integer iwwtba(30) equivalence (iwwtba(1),lwwtbl(1,1)) c integer iwwtbb(30) equivalence (iwwtbb(1),lwwtbl(1,31)) c integer iwwtbc(30) equivalence (iwwtbc(1),lwwtbl(1,61)) c integer iwwtbd(13) equivalence (iwwtbd(1),lwwtbl(1,91)) C C . . . . . . . . . . . . . . . . . . . INTEGER ISKELS(4,6) CHARACTER*1 LSKELS(32,6) EQUIVALENCE (ISKELS(1,1),LSKELS(1,1)) C INTEGER IWORKA(10) CHARACTER*1 LWORKA(40) EQUIVALENCE (LWORKA(1),IWORKA(1)) C INTEGER IDURGE(2) CHARACTER*1 LDURGE(8) EQUIVALENCE (LDURGE(1),IDURGE(1)) C EQUIVALENCE (LDURGE(1),LWORKF(1)) C INTEGER IWORKF(5) CHARACTER*1 LWORKF(MAXWKF) C C ... WHERE MAXWKF IS MAX NO. OF CHARS IN LWORKF = 48 C EQUIVALENCE (LWORKF(1),IWORKF(1)) C EQUIVALENCE (LWORKF(9),LWORKA(1)) C CHARACTER*40 IBCDBF CHARACTER*40 LWORKV EQUIVALENCE (LWORKA(1),LWORKV) CHARACTER*40 WORKWW C C ... BIT POSITIONS IN IPLOTQ - FOR WHICH OBS PARAMETERS GIVEN C INTEGER KN DATA KN / x'0000000000000001' / INTEGER KAVSBY DATA KAVSBY / x'0000000000000002' / INTEGER KAHHH DATA KAHHH / x'0000000000000004' / INTEGER KWW DATA KWW / x'0000000000000008' / INTEGER KNAME DATA KNAME / x'0000000000000010' / C CHARACTER*1 LCONT C CHARACTER*1 CFWDSP integer ifwdsp DATA iFWDSP / x'0900000000000000' / equivalence (ifwdsp,cfwdsp) CHARACTER*1 CBAKSP integer ibaksp DATA iBAKSP / x'0800000000000000' / equivalence (ibaksp,cbaksp) CHARACTER*1 CDOWLN integer idowln DATA iDOWLN / x'0D00000000000000' / equivalence (idowln,cdowln) CHARACTER*1 CSETSC integer isetsc DATA iSETSC / x'1200000000000000' / equivalence (isetsc,csetsc) CHARACTER*1 CRESET integer ireset DATA iRESET / x'1100000000000000' / equivalence (ireset,Creset) CHARACTER*1 CSLASH integer islash DATA iSLASH / x'2F00000000000000' / equivalence (islash,cslash) CHARACTER*1 CPLUS integer iplus DATA iPLUS / x'2B00000000000000' / equivalence (iplus,cplus) CHARACTER*1 CAM integer iam DATA iAM / x'4D00000000000000' / equivalence (iam,cam) CHARACTER*1 CAX integer iax DATA iAX / x'5800000000000000' / equivalence (iax,cax) CHARACTER*1 CUPSP integer iupsp DATA iUPSP / x'0B00000000000000' / equivalence (iupsp,cupsp) CHARACTER*1 L1 DATA L1 / '1' / CHARACTER*1 LT DATA LT / 'T' / CHARACTER*1 L00 integer i00 DATA i00 / x'0000000000000000' / equivalence (i00,l00) LOGICAL LOVRLP C CHARACTER*1 LCHAR C C . . . LOVRLP IS FLAG TO MARK THOSE MODELS IN WHICH PRES WX HAS C . . . OVERLAPPING CHARACTERS.................... C CHARACTER*2 RGTBKT integer igtbkt DATA iGTBKT /x'3108000000000000'/ equivalence (igtbkt,rgtbkt) C C ...... FOR RIGHT BRACKET AND BACK SPACE C CHARACTER*24 SPECWW(5) integer ispecw(3,5) INTEGER SPECIX(5) DATA SPECIX / 6, 4, 6, 16, 14 / C C ....FOR SPECIAL PRESENT WEATHER c LOGICAL ISEBCD LOGICAL MOBLOK LOGICAL MOREVB LOGICAL MOFFAN C C ... IWWTBM AND IWWTBK ARE HEX TEXT FOR PRESENT WEATHER C ... SYMBOLS 1-103. CATEGORY OF SKELETON AND NO. OF CHARS GIVEN. C DATA IWWTBa/ 1 x'0000000000000000', x'0000000000000000', x'0000000000000000', 2 x'01011C0000000000', x'01011D0000000000', x'01011E0000000000', 3 x'01011F0000000000', x'0101200000000000', x'0101210000000000', 4 x'0101220000000000', x'0101230000000000', x'0101240000000000', 5 x'0101250000000000', x'0101260000000000', x'0101270000000000', 6 x'0101280000000000', x'0101290000000000', x'01012A0000000000', 7 x'01012B0000000000', x'0202312C00000000', x'0202312D00000000', 8 x'0202312E00000000', x'0202312F00000000', x'0202313000000000', 9 x'0304322D33360000', x'0304322F33360000', x'0304323433360000', t x'0202534800000000', x'0202312900000000', x'0202393700000000'/ DATA IWWTBb/ 1 x'0101370000000000', x'0202373800000000', x'0202393A00000000', 2 x'01013A0000000000', x'02023A3800000000', x'01013B0000000000', 3 x'01013C0000000000', x'01013D0000000000', x'01013E0000000000', 4 x'0202534800000000', x'01013F0000000000', x'0202394000000000', 5 x'0202393500000000', x'0101400000000000', x'0101350000000000', 6 x'0202403800000000', x'0202353800000000', x'0101410000000000', 7 x'0101420000000000', x'01012C0000000000', x'02022C2C00000000', 8 x'0101430000000000', x'04032C2C2C000000', x'05022C4300000000', 9 x'06042C2C2C2C0000', x'0101410000000000', x'0101450000000000', t x'0101490000000000', x'05022C4900000000', x'01012D0000000000'/ DATA IWWTBc/ 1 x'02022D2D00000000', x'01014F0000000000', x'04032D2D2D000000', 2 x'05022D4F00000000', x'06042D2D2D2D0000', x'0101460000000000', 3 x'0101470000000000', x'01012F0000000000', x'05022E2F00000000', 4 x'01012E0000000000', x'02022E2E00000000', x'0101490000000000', 5 x'04032E2E2E000000', x'05022E5900000000', x'06042E2E2E2E0000', 6 x'01014A0000000000', x'01014B0000000000', x'01014C0000000000', 7 x'01014D0000000000', x'05022D3600000000', x'05022D4E00000000', 8 x'05024F3600000000', x'05022F3600000000', x'05022F4E00000000', 9 x'05022E3600000000', x'05022E4E00000000', x'0502343600000000', t x'0502344E00000000', x'0502503600000000', x'0502504E00000000'/ DATA IWWTBd/ 1 x'0202512900000000', x'0202522900000000', x'0202552900000000', 2 x'0202572900000000', x'05022D2900000000', x'0502342900000000', 3 x'05022D5800000000', x'0502372900000000', x'0502345800000000', 4 x'0202542900000000', x'0202562900000000', x'05022E2900000000', 5 x'05022E5800000000'/ C C ... ISKELS IS SKELETON FOR SIX POSSIBLE CATEGORIES OF C ... STATION MODELS. C DATA ISKELS/x'0D1200000D110000',x'0000000000000000', 1 x'0000000000000000',x'0000000000000000', 2 x'0D12080000000D11',x'0000000000000000', 3 x'0000000000000000',x'0000000000000000', 4 x'0D12080000000D08',x'0000110000000000', 5 x'0000000000000000',x'0000000000000000', 6 x'0D12090011080808',x'12000B0C0800000B', 7 x'0C09110000000000',x'0000000000000000', 8 x'0D1200000D001100',x'0000000000000000', 9 x'0000000000000000',x'0000000000000000', T x'0D12090011080808',x'12000A08000B0B0C', 1 x'0800000B0C091100',x'0000000000000000'/ C C ... KNSKEL DESCRIBES NO. OF BYTES/SKELETON, C ... NO. OF UNITS USED FOR WW SYMBOL, AND POSITION OF UNITS C ... IN SKELETON. C DATA KNSKEL/ x'0000000C', x'00000001', x'00000003', x'00000000', 1 x'00000000', x'00000000', x'0000000C', x'00000002', 2 x'00000005', x'00000004', x'00000000', x'00000000', 3 x'00000010', x'00000004', x'00000005', x'00000004', 4 x'0000000A', x'00000009', x'00000018', x'00000003', 5 x'0000000A', x'0000000E', x'0000000F', x'00000000', 6 x'0000000C', x'00000002', x'00000003', x'00000006', 7 x'00000000', x'00000000', x'0000001C', x'00000004', 8 x'0000000A', x'0000000D', x'00000013', x'00000012' / C C ... TABLE OF POINTERS FOR N(CLOUD COVER). C DATA ISPECW / 1 x'0D08424F12000000',x'0000000000000000',x'0000000000000000', 2 x'0D50120000000000',x'0000000000000000',x'0000000000000000', 3 x'0D08502D12000000',x'0000000000000000',x'0000000000000000', 4 x'0D08080808080854',x'4F524E41444F1200',x'0000000000000000', 5 x'0D0808080808564F',x'4C41534812000000',x'0000000000000000'/ DATA MSK8TH / 2 x'ff00000000000000', x'ffff000000000000', 3 x'ffffff0000000000', x'ffffffff00000000', 4 x'ffffffffff000000', x'ffffffffffff0000', 5 x'ffffffffffffff00', x'ffffffffffffffff'/ DATA CINCH / 100.0 / C DATA IALTER/93,94,95,102,97,101,101,101,101,101,101,101/ C C ...ADD 6 MORE INTO IALTER ARRAY FOR BO, P, P-, TORNADO, AND VOLASH C ...AND PRETEND THEY ARE IN CATEGORY 2 TO GET VISIBILITY C DATA MSTNCR / x'0E0F101314150102', x'0304050000000000' / integer ihcign equivalence(ihcigc,ihcign) save C C . . . . . . S T A R T . . . . . . . . . . . . . . . . . . . C c check input c ihcigc = ihcigh if(lchout) write(6,'('' in staplt: iu,ix,iy,iz,n,iv,iw,inc,'', 1 ''ihc,ns,ipq,mfs,lp,as'', 2 i4,i5,i5,i3,i4,1x,a4,i4,1x,z16,1x,a4, 3 1x,a8,z4,i2,1x,l1,1x,l1)') 4 iunit,idot,jdot,izoomt,n,ihvsby,iww,ihcign,ihcigh, 5 namstn,iplotq,mfonsz,lprt,autost c KERASE = 1 LOVRLP = .FALSE. IDOTS = IDOT JDOTS = JDOT ID = -16 JD = 6 IBS = 0 C C ... CLEARS STRING OF TEXT. C DO I = 1,14 ILSTR(I) = 0 enddo C C ...CLEARS VSBY STRING(SPECIAL CASE-CATEGORY 1 OR 5). C IDURGE(1) = 0 IDURGE(2) = 0 ILS = 0 IACC = IAND(IPLOTQ,KWW) IF(IACC .EQ. 0) GO TO 100 IF((IWW.LT.4).OR.(IWW.GT.110)) GO TO 100 C C ================================================================== C PLOTTING MODEL IF PRESENT WEATHER (WW) EXISTS C ================================================================== C ...MODIFICATION OF IWW TABLE TO MATCH PRESENT CONVENTION. C IWSAVE = IWW IF(IWW .GE. 100) IWW = IALTER(IWW-100+1) C C ...GET CATEGORY OF THIS IWW C ICATGO = mova2i(LWWTBL(1,IWW)) C LOVRLP = .FALSE. IF(ICATGO.EQ.4) LOVRLP = .TRUE. IF(ICATGO.EQ.6) LOVRLP = .TRUE. C C ...MOVES SKELETON INTO WORK AREA C ...HOW MANY BYTES ARE THERE IN THIS CATEGORY ? C NCH = KNSKEL(1,ICATGO) DO I = 1,NCH LWORKA(I) = LSKELS(I,ICATGO) enddo C C ...NOW GET THE ACTUAL PRESENT WEATHER CHARACTER INTO SKELETON C ...HOW MANY CHARACTER PIECES ARE NEEDED FOR THIS C IF (IWSAVE .LE. 105) THEN NWXCH = KNSKEL(2,ICATGO) DO I = 1,NWXCH I2 = I + 2 LCHAR = LWWTBL(I2,IWW) C C ...WHERE DO I STASH THIS CHAR INTO SKELETON ? C ISUBSC = KNSKEL(I2,ICATGO) LWORKA(ISUBSC) = LCHAR enddo ELSE C ....PLOTTING SPECIAL PRESENT WEATHER - BO, P, P-, TORN, VOLC C ....INTO WORKING ARRAY C PRINT *,' ** IN SUBR/STAPLT, FIND A SPECIAL WW=',IWSAVE ISVIDX = IWSAVE - 105 IEND = SPECIX(ISVIDX) WORKWW(1:IEND) = SPECWW(ISVIDX)(1:IEND) ENDIF C C ...PLOTTING VSBY C IACC = IAND(IPLOTQ,KAVSBY) IF(IACC .EQ. 0) GO TO 25 C C ...CONVERT CHAR WORD FROM EBDIC TO ASCII C if(ihvsby(1:4).eq.' ') go to 25 do i = 1,4 cavsby(i) = ihvsby(i:i) if (cavsby(i).eq.' ') cavsby(i) = '0' enddo C IF(cavsby(2) .NE. '0') then !vis has fraction IF(cavsby(1) .NE. '0') then !vis is ge 1 mile. IBS = IBS + 1 !plot leading digit and + sign LDURGE(IBS) = CBAKSP IBS = IBS + 1 LDURGE(IBS) = CAVSBY(1) IBS = IBS + 1 LDURGE(IBS) = CPLUS endif c c plot numerator of fraction and slash c IBS = IBS + 1 LDURGE(IBS) = CAVSBY(2) IBS = IBS + 1 LDURGE(IBS) = CSLASH c c plot denominator of fraction c IF(Cavsby(3) .NE. '0') then IBS = IBS + 1 LDURGE(IBS) = CAVSBY(3) endif if(cavsby(4) .ne. '0') then IBS = IBS + 1 LDURGE(IBS) = CAVSBY(4) endif else C C ...WHOLE NO. VSBY C IF((ICATGO .NE. 1) .AND. (ICATGO .NE. 5)) then IF(Cavsby(1) .NE. '0') then IBS = IBS + 1 LDURGE(IBS) = CFWDSP IBS = IBS + 1 LDURGE(IBS) = CAVSBY(1) endif else C C ...WHOLE NO. VSBY ON SAME LINE AS WW. C IBS = 1 LDURGE(IBS) = CDOWLN IBS = IBS + 1 LDURGE(IBS) = CBAKSP IBS = IBS + 1 LDURGE(IBS) = CAVSBY(1) IBS = IBS + 1 LDURGE(IBS) = CUPSP endif endif 25 continue C C ... PLOTTING N C IACC = IAND(IPLOTQ,KN) IF(IACC .EQ. 0) GO TO 60 IF((N .LT. 0).OR.(N .GT. 10)) GO TO 60 c C ....INSERT LOGIC FOR SPECIAL WW c IF (IWSAVE .LE. 105) THEN if(icatgo.eq.1.or.icatgo.ge.4) then LWORKA(4) = KSTNCR(N+1) else LWORKA(6) = KSTNCR(N+1) endif ELSEIF (IWSAVE .LE. 110) THEN c C ....POSITION THE STATION CIRCLE FOR SPECIAL WW c MINDEX = SPECIX(IWSAVE - 105) WORKWW(MINDEX:MINDEX) = KSTNCR(N+1) ENDIF 60 CONTINUE C C ... PLOTTING HEIGHTS C IACC = IAND(IPLOTQ,KAHHH) IF(IACC .EQ. 0) GO TO 70 C do i = 1,3 cahhh(i) = ihcigh(i:i) if (cahhh(i).eq." ") cahhh(i) = char(0) enddo C IF(ICATGO.EQ.1) then IPOS = 7 IPOS7 = mova2i(CAHHH(1)) IF(IPOS7 .EQ. 0) CAHHH(1) = CFWDSP elseIF(ICATGO .EQ. 2) then IPOS = 9 IPOS9 = mova2i(CAHHH(1)) IF(IPOS9 .EQ. 0) CAHHH(1) = CFWDSP elseIF(ICATGO .EQ. 3) then IPOS = 12 elseIF(ICATGO .EQ. 4) then IPOS = 20 elseIF(ICATGO .EQ. 5) then IPOS = 9 elseIF(ICATGO .EQ. 6) then IPOS = 24 endif IBCC = mova2i(CAHHH(1)) IF(IBCC .NE. 0) then LWORKA(IPOS) = CAHHH(1) endif IBCC = mova2i(CAHHH(2)) IF(IBCC .NE. 0) then LWORKA(IPOS+1) = CAHHH(2) endif IBCC = mova2i(CAHHH(3)) IF(IBCC .NE. 0) then LWORKA(IPOS+2) = CAHHH(3) endif 70 continue C C ..... SPECIAL WW, HEIGHTS NEEDS TO BE INSERTED INTO TEMP BUFFER C IF (IWSAVE .GT. 105) THEN MINDEX = SPECIX(IWSAVE - 105) + 1 IF (AUTOST) THEN C C ...INSERT BRACKET AFTER STATION CIRCLE C WORKWW(MINDEX:MINDEX+1) = RGTBKT MINDEX = MINDEX +2 ENDIF WORKWW(MINDEX:MINDEX) = CDOWLN MINDEX = MINDEX +1 WORKWW(MINDEX:MINDEX) = CRESET MINDEX = MINDEX +1 IF(ICATGO .EQ. 1) NBEGIN = 7 IF(ICATGO .EQ. 2) NBEGIN = 9 IF(ICATGO .EQ. 3) NBEGIN = 12 IF(ICATGO .EQ. 4) NBEGIN = 20 IF(ICATGO .EQ. 5) NBEGIN = 8 IF(ICATGO .EQ. 6) NBEGIN = 24 NLENG = NCH - NBEGIN WORKWW(MINDEX:MINDEX+NLENG) = LWORKV(NBEGIN:NCH) C C ....UNLOAD HEIGHTS TO WORKING ARRAY C MINDEX = MINDEX + NLENG IF (MINDEX .GT. 40) MINDEX = 40 LWORKV(1:MINDEX) = WORKWW(1:MINDEX) NCH = MINDEX C C ....UNLOAD TEMP WORKING ARRAY BACK TO BUFFER C C .... INSERT A RIGHT BRACKET HERE C elseif (AUTOST .AND. IWSAVE.LE.105) THEN ISERPT = 4 IF (ICATGO .EQ. 2 .OR. ICATGO .EQ. 3) ISERPT = 6 IBCDBF(1:ISERPT) = LWORKV(1:ISERPT) IBCDBF(ISERPT+1:ISERPT+2) = RGTBKT IBCDBF(ISERPT+3:NCH+2) = LWORKV(ISERPT+1:NCH) LWORKV(1:NCH+2) = IBCDBF(1:NCH+2) NCH = NCH + 2 ENDIF C C ... GIVEN NCH = NO. OF CHARS IN LWORKA C ... DOES NOT INCLUDE 8 PRECEDING CHARS OF VSBY IN LWORKF C NCHF = NCH + 8 C C ... NOW WE CAN WORK WITH THE COMBINED ARRAY LWORKF ... C IF(NCHF .GT. MAXWKF) NCHF = MAXWKF C C ... SQUEEZE OUT ANY BINARY ZERO CHARACTER C ... AND COUNT THE GOOD CHARACTERS ... C NC = 0 DO I = 1,NCHF IF(LWORKF(I) .NE. L00) then NC = NC + 1 LWORKF(NC) = LWORKF(I) endif enddo IF(NC .LE. 0) GO TO 810 C NWDS = NC / 8 IPARTW = MOD(NC,8) IF(IPARTW .NE. 0) then C C ... THERE IS A PARTIALLY FULL WORD ... C NWDS = NWDS + 1 IWORKF(NWDS) = IAND(IWORKF(NWDS),MSK8TH(IPARTW)) endif C C ... NOW LWORKF HAS CLEAN NWDS WORDS FOR SIMULATOR C ... AND NC CHARACTERS FOR ALFAR ... C IF(NWDS .le. 3) then C C ... STRING WILL FIT ON ONE CARD FOR SIMULATOR ... C NWDSA = NWDS NWDSB = 0 else NWDSA = 3 NWDSB = NWDS - 3 endif IF( LPRT ) THEN WRITE(IUNIT,900) IDOTS,JDOTS,ID,JD,MFONSZ,IZOOMT,NWDSA, 1 (IWORKF(I),I=1,NWDSA) 900 FORMAT(4I5,2I1,I2,3Z16) ENDIF C C ... CONVERT TO INCHES I,J,DELTAI,DELTAJ ... C XI = FLOAT(IDOTS) / CINCH YJ = FLOAT(JDOTS) / CINCH DX = FLOAT(ID) / CINCH DY = FLOAT(JD) / CINCH ZT = IZOOMT KERASE = 1 C MOBLOK = .TRUE. IF (LOVRLP) MOBLOK = .FALSE. MOREVB = .FALSE. MOFFAN = .TRUE. ISEBCD = .FALSE. IRETN = 0 ix = idots iy = jdots idx = id idy = jd isize = 0 call afmdc8(lworkf,nc,ix,iy,idx,idy, x moblok,morevb,zt,isize,iretn) C C .... TO CLOSE THE OUTPUT BUFFER C IF(NWDSB .LE. 0) GO TO 810 C C ... OTHERWISE, DO THE CONTINUATION CARD FOR SIMULATOR ... C JNWDS = NWDSB + 7 IF(JNWDS .GT. 14) JNWDS = 14 IDOTS = 0 JDOTS = 0 ID = 0 JD = 0 LCONT = L1 IF ( LPRT ) THEN WRITE(IUNIT,905) IDOTS,JDOTS,ID,JD,MFONSZ,IZOOMT,LCONT,NWDSB, 1 (IWORKF(I),I=8,JNWDS) 905 FORMAT(4I5,2I1,A1,I1,7Z8) ENDIF C GO TO 810 C C ... WHICH IS EXIT ... C ... ALL FINISHED WITH THE STATION WITH PRESENT WEATHER SYMBOL. C C ================================================================== C PLOTTING MODEL IF NO PRESENT WEATHER C ================================================================== C 100 CONTINUE C C ...PLOTTING VSBY FOR NO WW CASE. C IACC = IAND(IPLOTQ,KAVSBY) IF(IACC .EQ. 0) GO TO 400 C C ...CONVERT VSBY TO 4 CHAR WORD FROM EBDIC TO ASCII C do i = 1,4 cavsby(i) = ihvsby(i:i) if (cavsby(i).eq." ") cavsby(i) = char(0) enddo IBCC = mova2i(CAVSBY(2)) IF(IBCC.NE.0) GO TO 300 C C ...OTHERWISE, THE NUMERATOR OF THE FRACTION IS NOT A VALID NO. C IBCC = mova2i(CAVSBY(1)) IF(IBCC .EQ. 0) GO TO 400 C C ...SINCE NO WW AND NO FRACTIONAL VSBY, C ...PLOT THIS INTEGER VSBY IN WW POSITION C 250 CONTINUE ILS = ILS + 1 LSTR(ILS) = CDOWLN ILS = ILS + 1 LSTR(ILS) = CAVSBY(1) ILS = ILS + 1 LSTR(ILS) = CBAKSP GO TO 500 C 300 CONTINUE C C ...IS IT A CHAR 0 FOR THE NUMERATOR OF FRACTION? C idcc = mova2i("0") IF(IDCC.EQ.IBCC) GO TO 250 IBCC = mova2i(CAVSBY(1)) IF(IBCC .NE. 0) then ILS = ILS + 1 LSTR(ILS) = CBAKSP ILS = ILS + 1 LSTR(ILS) = CAVSBY(1) ILS = ILS + 1 LSTR(ILS) = CPLUS endif C ILS = ILS + 1 LSTR(ILS) = CAVSBY(2) ILS = ILS + 1 LSTR(ILS) = CSLASH IBCC = mova2i(CAVSBY(3)) IF(IBCC .NE. 0) then ILS = ILS + 1 LSTR(ILS) = CAVSBY(3) endif ILS = ILS + 1 LSTR(ILS) = CAVSBY(4) C C ...WHICH FINISHED VSBY LINE C 400 CONTINUE ILS = ILS + 1 LSTR(ILS) = CDOWLN C 500 CONTINUE C C ... PLOTTING N FOR NO WW CASE ... C ILS = ILS + 1 LSTR(ILS) = CSETSC ILS = ILS + 1 LSTR(ILS) = CFWDSP IACC = IAND(IPLOTQ,KN) IF(IACC .NE. 0) then C C ...ERRONEOUS N GIVEN TO ME, SO SET IT TO MISSING M C IF((N .LT. 0) .OR. (N .GT. 10)) N = 10 ILS = ILS + 1 LSTR(ILS) = KSTNCR(N+1) C C .... INSERT A RIGHT BRACKET HERE C IF (AUTOST) THEN ILS = ILS + 1 LSTR(ILS) = RGTBKT(1:1) ILS = ILS + 1 LSTR(ILS) = RGTBKT(2:2) ENDIF C endif C C ... PLOTTING NAME FOR NO WW CASE ... C ILS = ILS + 1 LSTR(ILS) = CRESET do i = 1,6 cname(i) = namstn(i:i) enddo C IACC = IAND(IPLOTQ,KNAME) IF(IACC .NE. 0) then DO I = 1,6 iacc = 0 if ((cname(i).ge."0").and.(cname(i).le."9")) iacc = 1 if ((cname(i).ge."a").and.(cname(i).le."z")) iacc = 1 if ((cname(i).ge."Z").and.(cname(i).le."Z")) iacc = 1 IF(IACC .NE. 0) then C C ...VALID CHARACTER C ILS = ILS + 1 lstr(ILS) = CNAME(I) endif enddo endif IACC = IAND(IPLOTQ,KAHHH) IF( IACC .EQ. 0) GO TO 800 ILS = ILS + 1 LSTR(ILS) = CDOWLN C C ...PLOTTING HHH FOR NO WW CASE. C do i = 1,3 cahhh(i) = ihcigh(i:i) if (cahhh(i).eq." ") cahhh(i) = char(0) enddo C IBCC = mova2i(CAHHH(1)) IF(IBCC .EQ. 0) GO TO 750 ILS = ILS + 1 LSTR(ILS) = CAHHH(1) IBCC = mova2i(CAHHH(2)) IF(IBCC .EQ. 0) THEN ILS = ILS + 1 LSTR(ILS) = CAX ELSE ILS = ILS + 1 LSTR(ILS) = CAHHH(2) ENDIF 780 CONTINUE IBCC = mova2i(CAHHH(3)) IF(IBCC .EQ. 0) GO TO 790 785 CONTINUE ILS = ILS + 1 LSTR(ILS) = CAHHH(3) GO TO 800 790 CONTINUE ILS = ILS + 1 LSTR(ILS) = CAX GO TO 800 750 CONTINUE ILS = ILS + 1 LSTR(ILS) = CFWDSP IBCC = mova2i(CAHHH(2)) IF(IBCC.NE.0) THEN ILS = ILS + 1 LSTR(ILS) = CAHHH(2) GO TO 780 endif C IBCC = mova2i(CAHHH(3)) IF(IBCC.NE.0) GO TO 785 C C ...THAT IS ODD, TOLD TO PLOT HHH, AND NOTHING IS THERE C ILS = ILS + 1 LSTR(ILS) = CAM 800 CONTINUE C C ... GIVEN ILS = NO. OF CHARACTERS IN LSTR ... C NC = ILS IF(NC .LE. 0) GO TO 810 C NWDS = NC / 4 IPARTW = MOD(NC,4) IF(IPARTW .NE. 0) then C C ... THERE IS A PARTIALLY FULL WORD ... C NWDS = NWDS + 1 endif IF(NWDS .le. 7) then C C ... THE STRING WILL FIT ON ONE SIMULATOR CARD ... C NWDSA = NWDS NWDSB = 0 else NWDSA = 7 NWDSB = NWDS - 7 endif IF(LPRT) THEN WRITE(IUNIT,900)IDOTS,JDOTS,ID,JD,MFONSZ,IZOOMT,NWDSA, 1 (ILSTR(I),I=1,NWDSA) endif C C ... CONVERT TO INCHES I,J,DELTAI,DELTAJ FOR ALFAR ... C XI = FLOAT(IDOTS) / CINCH YJ = FLOAT(JDOTS) / CINCH DX = FLOAT(ID) / CINCH DY = FLOAT(JD) / CINCH ZT = IZOOMT C MOBLOK = .TRUE. MOREVB = .FALSE. MOFFAN = .TRUE. ISEBCD = .FALSE. IRETN = 0 ix = idots iy = jdots idx = id idy = jd isize = 0 call afmdc8(lstr,nc,ix,iy,idx,idy, x moblok,morevb,zt,isize,iretn) C C .... TO CLOSE THE OUTPUT BUFFER C IF(NWDSB .GT. 0) then C C ... DO A CONTINUATION CARD FOR THE SIMULATOR ... C JNWDS = NWDSB + 7 IF(JNWDS .GT. 14) JNWDS = 14 IDOTS = 0 JDOTS = 0 ID = 0 JD = 0 LCONT = L1 IF( LPRT ) THEN WRITE(IUNIT,905) IDOTS,JDOTS,ID,JD,MFONSZ,IZOOMT,LCONT, 1 nwdsb,(ILSTR(I),I=8,JNWDS) ENDIF endif C 810 CONTINUE RETURN END