subroutine afgrib(launit,fld,iy4,imo,idy,ihr,iretc) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: afgrib DESCRIPTIVE TITLE NOT PAST COL 70 C PRGMMR: caruso ORG: W/NP12 DATE: 99-07-14 C C ABSTRACT: set up kpds and kgds for grib output C C PROGRAM HISTORY LOG: C YY-MM-DD ORIGINAL AUTHOR unknown C 98-06-08 chris caruso making y2k compliant. C 98-11-23 bill facey change grib parameters for C AFOSMAKR90 C C USAGE: CALL afgrib(launit,fld,iy4,imo,idy,ihr,iretc) C INPUT ARGUMENT LIST: c launit - integer unit number of grib file to be written c fld - fld to be written out in grib format c iy4 - integer 4 digit year c imo - integer month c idy - integer day c ihr - integer hour C C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) c iretc - return code c - = 0, all ok c - = other, w3fi72 grib packer return code. C C OUTPUT FILES: (DELETE IF NO OUTPUT FILES IN SUBPROGRAM) C fort.83 - output grib file C C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION C C SUBPROGRAMS CALLED: C W3LIB - PUTGB R63W72 GETBIT W3FI72 WRYTE C C ATTRIBUTES: C LANGUAGE: Cray FORTRAN 90 C MACHINE: CRAY C C$$$ real fld(73,47) real fldlfm(53,45) integer kpds(200) integer kgds(200) logical lb(2385) !53x45 c logical lb(3431) !73x47 c putgb expects lb to be logical*1 of size kf. Here, kf = 53 x 45. c old version of this s/r had the other initialization where lb was c of size 73 x 47. c integer jha(7) integer iha(7) real fha(7,7) real fhl(7) c data fhl/-0.0625,-0.0625,0.3125,0.6250,0.3125,-0.0625,-0.0625/ c data fhl/-0.0625, 0.0 ,0.3125,0.5000,0.3125, 0.0 ,-0.0625/ c data fhl/-0.125 , 0.0 ,0.3750,0.5000,0.375 , 0.0 ,-0.125 / c empirical amplitude preserving interpolation::w data fhl/-0.0971,-0.1183,0.3713,0.5572,0.3713,-0.1183,-0.0971/ c data fhl/ 0.0 , 0.0 ,0.25 ,0.5000,0.2500, 0.0 , 0.0 / save c c write input c write(6,'('' in afgrib: unit,date'',5i6)') launit,iy4,imo,idy,ihr c c move data from double-res LFM grid to LFM grid c double-res grid: 31,11 at 105w,30n c lfm grid: 27,13 at 105w,30n c do j = 1,45 do i = 1,53 fldlfm(i,j) = 2.5 enddo enddo do j = 1,7 do i = 1,7 fha(i,j) = fhl(i) * fhl(j) enddo enddo do j = 1,45 jha(4) = 2 * (j - 13) + 11 jha(1) = jha(4) - 3 jha(2) = jha(4) - 2 jha(3) = jha(4) - 1 jha(5) = jha(4) + 1 jha(6) = jha(4) + 2 jha(7) = jha(4) + 3 do ji = 1,7 jh = jha(ji) if ((jh.ge.1).and.(jh.le.47)) then do i = 1,53 iha(4) = 2 * (i - 27) + 31 iha(1) = iha(4) - 3 iha(2) = iha(4) - 2 iha(3) = iha(4) - 1 iha(5) = iha(4) + 1 iha(6) = iha(4) + 2 iha(7) = iha(4) + 3 do ii = 1,7 ih = iha(ii) if((ih.ge.1).and.(ih.le.73)) then fldlfm(i,j) = fldlfm(i,j) + (fld(ih,jh) - 2.5) * * fha(ii,ji) endif enddo enddo endif enddo enddo fmin = 1.0E99 fmax = -1.0E99 imin = 0 jmin = 0 imax = 0 jmax = 0 do j = 1,45 do i = 1,53 if (fmin.gt.fldlfm(i,j)) then fmin = fldlfm(i,j) imin = i jmin = j endif if (fmax.lt.fldlfm(i,j)) then fmax = fldlfm(i,j) imax = i jmax = j endif if (fldlfm(i,j).lt.2.2) then fldlfm(i,j)= 2.2 endif if (fldlfm(i,j).gt.4.8) then fldlfm(i,j) = 4.8 endif enddo enddo write(6,'('' In afgrib: fmax, i, j'',E20.13,2i5)')fmax,imax,jmax write(6,'('' In afgrib: fmin, i, j'',E20.13,2i5)')fmin,imin,jmin c C set up grib input parameters for the analysis grid c lugb = launit kf = 53 * 45 c c initialize lb to all .false. c do k = 1,kf lb(k) = .false. enddo do i = 1,200 kpds(i) = 0 kgds(i) = 0 enddo c C kpds(1) = id of center. here, = NCEP c kpds(2) = generating process id number c kpds(3) = grid definition specified in gds (lfm grid old number 26) c kpds(4) = gds/bms flag, either 1 or 0 c kpds(5) = indicator of parameter. use total cloud cover. c kpds(6) = type of level, here = sfc c kpds(7) = height/pressure, etc. of level c kpds(8) = year of century (either last 2 digits, or 100 if c mod(year,100) = 0) c kpds(9) = month c kpds(10)= day c kpds(11)= hour c kpds(13)= forecast time unit, hour c kpds(14)= time range 1 c kpds(15)= time range 2 c kpds(16)= time range flag c kpds(17)= number included in average c kpds(18)= version number of grib c kpds(19)= version number of parameter table c kpds(20)= number missing from average c kpds(21)= century of reference time of data (2 digits). c if mod(yr,100) = 0, century is still that of previous c year. e.g. year 2000 has kpds(8) = 100 and kpds(21) c = 20). year 2001 has kpds(8) = 01 and kpds(21) = 21 c kpds(22)= units decimal scale factor c kpds(23)= subcenter number 3, NCEP central operations , 0 not specified c kpds(24)= pds byte 29, for ncep ensemble products c kpds(25)= pds byte 30, not used c kpds(1) = 7 kpds(2) = 19 !previously, was = 159 kpds(3) = 6 !previously, was = 26 c kpds(2) = 159 c kpds(3) = 26 kpds(4) = 128 c kpds(5) = 71 !total cloud cover kpds(5) = 210 c kpds(5) = 02 kpds(6) = 1 !surface c kpds(6) = 102 kpds(7) = 0 iyrrem = mod(iy4,100) if(iyrrem.eq.0) then kpds(8) = 100 else kpds(8) = iyrrem endif kpds(9) = imo kpds(10) = idy kpds(11) = ihr kpds(12) = 0 kpds(13) = 1 kpds(14) = 0 kpds(15) = 0 kpds(16) = 0 kpds(17) = 0 kpds(18) = 2 !previously, was = 1 kpds(19) = 2 kpds(20) = 0 if(iyrrem.eq.0) then kpds(21) = iy4/100 else kpds(21) = (iy4/100) + 1 endif kpds(22) = 3 kpds(23) = 3 !previously, was = 0 kpds(24) = 0 kpds(25) = 0 c c grid description section C (1) - DATA REPRESENTATION TYPE C (2) - N(I) NR POINTS ALONG LAT CIRCLE C (3) - N(J) NR POINTS ALONG LON CIRCLE C (4) - LA(1) LATITUDE OF ORIGIN C (5) - LO(1) LONGITUDE OF ORIGIN C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) C (7) - LOV GRID ORIENTATION C (8) - DX - X DIRECTION INCREMENT C (9) - DY - Y DIRECTION INCREMENT C (10) - PROJECTION CENTER FLAG C (11) - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28) C (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS C (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE C PARAMETERS C OR C OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS C IN EACH ROW C OR C 255 IF NEITHER ARE PRESENT c kgds(1) = 5 !lfm, polar stereographic grid kgds(2) = 53 kgds(3) = 45 kgds(4) = 11530 kgds(5) = 226557 kgds(6) = 0 kgds(7) = 255000 kgds(8) = 190500 kgds(9) = 190500 kgds(10) = 0 kgds(11) = 64 kgds(19) = 0 kgds(20) = 255 c c create the grib message c call putgb(lugb,kf,kpds,kgds,lb,fldlfm,iret) write(6,'('' in afgrib: iret'',i20)') iret iretc = iret return end c********************************************************************* SUBROUTINE AFMDC5(INTEXT,NOCHAR,IX,IY,B,RB,ZT,ISIZE,IRETN) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: AFMDC5 PUT TEXT ON AFOS GRAPHICS. C PRGMMR: LUKE LIN ORG: W/NMC41 DATE: 96-12-18 C C ABSTRACT: PUTS TEXT (MODE C5) ON AFOS GRAPHICS PRODUCTS. THE TEXT C IN ASCII IS PASSED IN INTEXT. C C PROGRAM HISTORY LOG: C 96-12-18 ORIGINAL AUTHOR LUKE LIN. c 98-06-19 chris caruso - extend common ispaceaf to equal length c of that common in s/r iniafbin C C USAGE: CALL AFMDC5(INTEXT,NOCHAR,IX,IY,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 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 /ISPACEAF/LBLOCK,ICNTOT,LBNKFG,lword4,maxcnt,ndsrn, c idum1,idum2,idum3,idum4,idum5 C C OUTPUT ARGUMENT LIST: C IRETN - =0, NOMAL C =5, EXCEED THE ISPACE C =11, HIGH/LOW STRING ERROR c COMMON /ISPACEAF/LBLOCK,ICNTOT,LBNKFG,lword4,maxcnt,ndsrn, c idum1,idum2,idum3,idum4,idum5 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 INTEGER MODE C INTEGER MODEHD C CHARACTER*1 ABLANK CHARACTER*1 BIGHI CHARACTER*1 BIGLO CHARACTER*2 CMEDIA CHARACTER*1 INTEXT(NOCHAR) CHARACTER*1 OUTEXT(256) INTEGER IOUTXT(2) EQUIVALENCE (IOUTXT(1),OUTEXT(1)) C DATA MODEHD /Z'C540'/ save C 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 + 6 + NOCHAR NOCH = NOCHAR + 1 IF(ITOT .GT. 16384) THEN IRETN = 5 WRITE(6,FMT='('' AFMDC5: 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 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 . . . CACULATE NUMBER OF HALF WORDS.... IF(IREM.EQ.1) THEN ICNTOT = ICNTOT + 1 LBLOCK(ICNTOT) = ABLANK LBNKFG = - 1 ENDIF C print *, ' end of afmdc5, icntot=', icntot RETURN END c********************************************************************* SUBROUTINE ANALYS(NOBS,GUESS,IDIM,JDIM) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: ANALYS ANALYZE THE DATA. C PRGMMR: WOBUS ORG: W/NP20 DATE: 97-01-24 C C ABSTRACT: using guess as input background field, analyzes observed c data (reanalyzes the guess using the observed data). C C PROGRAM HISTORY LOG: C 80-04-01 DAVE SHIMOMURA C 94-01-04 LUKE LIN CONVERT IT FORTRAN 77 AND ADD DOC BLOCK. C 97-01-24 RICHARD WOBUS - CONVERT TO CRAY c 98-05-28 chris caruso removed cdir$ integer=64 from top c of this s/r for f90. c 98-06-05 chris caruso changed to use Dave Shimomura's sorter c routine. fixed logic around label 310. C C USAGE: CALL ANALYS(NOBS,GUESS,IDIM,JDIM) C INPUT ARGUMENT LIST: C NOBS - NO OF OBS IN FIJDAT ARRAY C FIJDAT - ARRAY OF OBS DATA. C JTM - J-DIMENSION OF FIJDAT C C NOBS - NUMBER OF OBSERVATIONS TO BE ANALYZED. C GUESS - FIRST GUESS OF THE DESIRED FIELD. C IDIM - I DIMENSION OF THE DESIRED FIELD. C JDIM - J DIMENSION OF THE DESIRED FIELD. C C C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) C ERRFLAG - EVEN IF MANY LINES ARE NEEDED C C C ATTRIBUTES: C LANGUAGE: cray fortran 90 C MACHINE: CRAY4 C C$$$ COMMON/RIJDAT/FIJDAT(3,2700) c C ...WHERE FIJDAT CONTAINS STATION I,J, AND DATA IN FLOATING POINT. c COMMON/ISPACE/DATA1(2700),FIWORD(2700),FJWORD(2700), X XD(2700),NISW(2,2700),KQUAD(2700), X KQUAD1(2700),ISWK(2700), X ADATA(2,2700),XTRA(100) C REAL ADATA C integer isortw(2700) integer mskrhs data mskrhs /X'FFFFFFFF'/ integer iacc REAL GUESS(IDIM,JDIM) REAL RADII(5) data RADII /0.0,2.5,1.75,.9,0.0/ REAL TW9TH data TW9TH /256.0/ C INTEGER IDIXAD(65) INTEGER IDIXCO(65) INTEGER KKTBL(9) data KKTBL /-1, 0, 0, 0, 0, 1, 1, 0, 0/ INTEGER N216TH data N216TH /65536/ save C C ...SELECT THE INFLUENCE RADII... C write(6,'('' in analys: begin'')') IF(NOBS.GT.2700) then PRINT 11,NOBS 11 FORMAT(' THE NUMBER OF OBSERVATIONS PASSED TO ANALYS IS', * ' TOO LARGE FOR THAT SUBROUTINE. NOBS = ',I2,'.', * ' JOB TERMINATED IN ANALYS.') STOP 10 endif KKTBL(2) = IDIM KKTBL(3) = JDIM KKTBL(4) = JDIM KKTBL(5) = JDIM KKTBL(9) = IDIM NJROWS = KKTBL(3) JMIN = KKTBL(7) JMAX = KKTBL(5) IMIN = KKTBL(6) IMAX = KKTBL(2) JMX = JMAX - 1 C C DETERMINE THE BEST METHOD FOR INTERPOLATING POINT BY POINT. C write(6,'('' in analys: before do 100'')') DO IX = 1,NOBS ISTA = FIJDAT(1,IX) JSTA = FIJDAT(2,IX) KQUAD(IX) = 0 c C ...WORK WITH LOWER LEFT CORNER OF GRID SQUARE AS BASE POINT... c IMINP1 = IMIN + 1 IMAXM1 = IMAX - 1 JMINP1 = JMIN + 1 IF((JSTA .GE. JMINP1) .AND. (JSTA .LT. JMX)) GO TO 10 GO TO 20 10 CONTINUE IF((ISTA .GE. IMINP1) .AND. (ISTA .LT. IMAXM1)) GO TO 30 20 CONTINUE IF((JSTA .GE. JMAX) .OR. (JSTA .LT. JMIN)) GO TO 40 IF((ISTA .GE. IMAX) .OR. (ISTA .LT. IMIN)) GO TO 40 KQUAD(IX) = 5 GO TO 40 c C ...BI-QUADRATIC INTERPOLATION POINTS AVAILABLE... c 30 CONTINUE KQUAD(IX) = 6 40 CONTINUE ISTA = (FIJDAT(1,IX) * TW9TH) + 0.5 NISW(1,IX) = (JSTA * N216TH) + ISTA enddo C write(6,'('' in analys: before do 150'')') DO I = 1,NOBS NISW(2,I) = I DATA1(I) = FIJDAT(3,I) FIWORD(I) = FIJDAT(1,I) FJWORD(I) = FIJDAT(2,I) KQUAD1(I) = KQUAD(I) enddo write(6,'('' in analys: after 150'')') c call dave's sorter routine do i = 1,nobs iacc = ishft(nisw(1,i),32) isortw(i) = ior(iacc,nisw(2,i)) enddo call piksor(isortw,nobs) write(6,'('' in analys: before do 250'')') DO I = 1,NOBS c NX = NISW(2,I) nx = iand(isortw(i),mskrhs) FIJDAT(1,I) = FIWORD(NX) FIJDAT(2,I) = FJWORD(NX) FIJDAT(3,I) = DATA1(NX) KQUAD(I) = KQUAD1(NX) enddo write(6,'('' in analys: after 250'')') C C ...BEGIN DIXIE... C ...TO FORM COUNT BY ROWS AND SUBSCRIPT OF STN ON THAT ROW... C IJADR = 1 ISWITA = 0 write(6,'('' in analys: before do 300'')') DO I = 1,JMAX IDIXAD(I) = 0 IDIXCO(I) = 0 enddo KSTRIP = 0 JCURR = 1 c C ...LUPA... c write(6,'('' in analys: before do 320'')') c DO I = 1,NOBS JSTN = FIJDAT(2,I) 310 CONTINUE IF (JCURR .LT. JSTN) then IDIXAD(JCURR) = IJADR IJADR = IJADR + KSTRIP IDIXCO(JCURR) = KSTRIP KSTRIP = 0 JCURR = JCURR + 1 IF (JCURR .GT. NJROWS) GO TO 340 GO TO 310 endif KSTRIP = KSTRIP + 1 enddo c C ...ALL THRU BIN, NO MORE OBS TO DO... c ISWITA = 1 331 CONTINUE IDIXAD(JCURR) = IJADR IJADR = IJADR + KSTRIP IDIXCO(JCURR) = KSTRIP KSTRIP = 0 JCURR = JCURR + 1 IF (JCURR .GT. NJROWS) GO TO 340 IF (ISWITA .NE. 0) GO TO 331 c C ...ENDING... c 340 CONTINUE IDIXCO(NJROWS+1) = IJADR - 1 write(6,'('' in analys: after 340'')') C C ...ALL FINISHED DIXIE... C START SCAN LOOP C DO NSN = 2,5 C C INTERPOLATE GUESS TO DATA LOCATIONS C DO I = 1,NOBS STI = FIJDAT(1,I) STJ = FIJDAT(2,I) CALL INTERP(GUESS,IMAX,JMAX,XD(I),STI,STJ,KQUAD(I)) enddo IF (NSN .EQ. 5) GO TO 1000 SCANR = RADII(NSN) RSQ = SCANR * SCANR KRAD = SCANR ERAS = KRAD IF(SCANR - ERAS .NE. 0.) KRAD = KRAD + 1 C C ADJUST VALUES AT GRID POINTS C DO 500 J = JMIN,JMAX FJ = J JBOT = J - KRAD JTOP = J + KRAD - 1 IF(JBOT.LT.JMIN) JBOT = JMIN IF(JTOP.GT.JMX) JTOP = JMX DO 440 I = IMIN,IMAX ILFT = I - KRAD IRGT = I+KRAD HCNT = 0.0 HCORR = 0.0 HWT = 0.0 WHMAX = 0.0 DO 430 JD = JBOT,JTOP ICNT = IDIXCO(JD) c c DATA COUNT FOR JD ROW c IF (ICNT .EQ. 0) GO TO 430 IX = 0 IA = IDIXAD(JD) c C POSITION IN DATA ARRAYS FOR FIRST POINT IN JD ROW c 410 CONTINUE STI = FIJDAT(1,IA) ISTA = STI IF (ISTA .GT. IRGT) GO TO 430 c C GET NEXT ROW c IF (ISTA .LT. ILFT) GO TO 420 c C GET NEXT REPORT c STJ = FIJDAT(2,IA) FI = I DLTJ = FJ - STJ DLTI = FI - STI DSQ = DLTI * DLTI + DLTJ * DLTJ WT = (RSQ - DSQ)/(RSQ + DSQ) IF (WT .LE. 0.0) GO TO 420 HCORR = HCORR + WT*(FIJDAT(3,IA) - XD(IA)) HCNT = HCNT + 1. HWT = HWT + WT c C SAVE LARGEST WEIGHT FOR CATCH c IF (WT.GT.WHMAX) WHMAX = WT c C DONE WITH THIS REPORT c 420 CONTINUE IX = IX + 1 IF (ICNT .EQ. IX) GO TO 430 IA = IA + 1 GO TO 410 430 CONTINUE IF (HCNT .EQ. 0.0) GO TO 440 IF(HCNT.GE.3.) WHMAX = 1. GUESS(I,J) = GUESS(I,J) + (HCORR/HWT) * WHMAX c C ...COMPLETES SWEEP OF GRID WHEN 440 LOOP IS DONE... c 440 CONTINUE 500 CONTINUE c C COMPLETES SCANS REQUESTED WHEN 70 LOOP DONE c enddo 1000 CONTINUE print*,' completed analys' RETURN END c********************************************************************* SUBROUTINE B4SORT(INDATA,IDIM,JDIM,DOTSGI,NFOUND) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: B4SORT PREPARE FOR THE SORTING. C PRGMMR: WOBUS ORG: W/NP20 DATE: 97-01-24 C C ABSTRACT: TO PREPARE FOR THE SORTING. C C PROGRAM HISTORY LOG: C 80-04-01 UNKOWN C 94-01-04 LUKE LIN CONVERT IT FORTRAN 77 AND ADD DOC BLOCK. C 97-01-24 RICHARD WOBUS - CONVERT TO CRAY c 98-05-28 chris caruso removed cdir$ integer=64 from top c of this s/r for f90. C C USAGE: CALL B4SORT(INDATA,IDIM,JDIM,DOTSGI,NFOUND) C INPUT ARGUMENT LIST: C INDATA - INPUT DATA FIELD C IDIM,JDIM- DIMENSION OF THE INPUT DATA FIELD. C ...GIVEN... INDATA(1,J) = IDOTS C INDATA(2,J) = JDOTS C DOTSGI - DOTS PER GRID INTERVAL C C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) C NFOUND - NUMBER OF DATA ITEMS FOUND IN INDATA C C REMARK: TO MAKE A SORT KEY OF JJJ/III/IFR/JFR C EACH ZONE IN A HALFWORD C REPLACING THE IDOTS AND JDOTS WORDS IN GIVEN INDATA C AND TO FORM A THINNING PRIORITY FROM THE C FLIGHT CATEGORY IN INDATA(4,J), AND STUFF IT INTO C THE LEFT HALF OF THE SAME WORD, SQUEEZING THE C FLIGHT CATEGORY INTO A HALF WORD. C ...CAUTION: ASSUMES THE INDATA ARRAY OF DATA ENDS WHEN THIS C ENCOUNTERS AN ITEM WHICH HAS ZERO FOR BOTH IDOTS C AND JDOTS WORDS. C C C ATTRIBUTES: C LANGUAGE: cray fortran 90 C MACHINE: CRAY4 C C$$$ C INTEGER INDATA(IDIM,JDIM) INTEGER IHAFWD(4) INTEGER IFULWD(2) DATA TWOB16 / 65536.0 / data iscal2 / x'0000000000010000' / data iscal4 / x'0000000100000000' / data mask12 / x'ffffffff00000000' / data mask22 / x'00000000ffffffff' / save C NFOUND = 0 DO JJ = 1,JDIM C IDOTS = INDATA(1,JJ) c JDOTS = INDATA(2,JJ) IDOTS = iand(INDATA(1,JJ),mask12)/iscal4 JDOTS = iand(INDATA(1,JJ),mask22) IF(IDOTS .EQ. 0) then IF(JDOTS .EQ. 0) GO TO 299 endif NFOUND = NFOUND + 1 GRIDJJ = FLOAT(JDOTS) / DOTSGI + 1.0 GRIDII = FLOAT(IDOTS) / DOTSGI +1.0 JGRID = GRIDJJ IHAFWD(1) = JGRID FRACTJ = GRIDJJ - FLOAT(JGRID) JFRACT = FRACTJ * TWOB16 IHAFWD(4) = JFRACT C IGRID = GRIDII IHAFWD(2) = IGRID FRACTI = GRIDII - FLOAT(IGRID) IFRACT = FRACTI * TWOB16 IHAFWD(3) = IFRACT IFULWD(1) = IHAFWD(1) * iscal2 + IHAFWD(2) IFULWD(2) = IHAFWD(3) * iscal2 + IHAFWD(4) indata(1,jj) = ifulwd(1) * iscal4 + ifulwd(2) C icat = iand(indata(2,jj),mask22) C ... INITIALIZE IPRIOR TO 'MISSING' ... IPRIOR = -9 IF(ICAT .EQ. 0) IPRIOR = 1 C ... WHICH IS VFR IF(ICAT .EQ. 1) IPRIOR = 3 C ... WHICH IS IFR IF(ICAT .EQ. 2) IPRIOR = 2 C ... WHICH IS MVFR IHAFWD(1) = IPRIOR IHAFWD(2) = ICAT IFULWD(1) = IHAFWD(1) * iscal2 + IHAFWD(2) INDATA(2,JJ) = ior(iand(indata(2,jj),mask12), 1 iand(IFULWD(1) ,mask22)) enddo 299 CONTINUE RETURN END c********************************************************************* SUBROUTINE DIXIED(NDATA,ITM,JTM,IJTH,MSKJJ,IDIXAD,IDIXCO,NDIX, 1 IERR) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: DIXIED TO FILL STRIP COUNT ARRAY AND STARTING C PRGMMR: WOBUS ORG: W/NP20 DATE: 97-01-24 C C ABSTRACT: TO FILL STRIP COUNT ARRAY AND STARTING POINTER OF EACH STRIP C C PROGRAM HISTORY LOG: C 79-06-01 DAVE SHIMOMURA C 94-01-04 LUKE LIN CONVERT IT FORTRAN 77 AND ADD DOC BLOCK. C 97-01-24 RICHARD WOBUS - CONVERT TO CRAY c 98-05-28 chris caruso removed cdir$ integer=64 from top c of this s/r for f90. C C USAGE: CALL SHLSRS(ADATA,ITM,JTM,ISKEY,MSKEYL,MSKEYR,NOBS,IERR) C INPUT ARGUMENT LIST: C NDATA - IS A real ARRAY OF OBSERVATIONAL DATA C ITM,JTM - IS A real ARRAY OF OBSERVATIONAL DATA C IJTH - POINTS TO THE WORD WITHIN THE ITM WORDS WHICH C CONTAINS THE GRID J COORDINATE C MSKJJ - MASKS THE INTEGER PORTION OF THE GRID J FROM THE C IJTH WORD ... C CAUTION ... C ... ASSUMES THE INTEGER PORTION OF GRID J IS POSITIONED C ... SOMEWHERE IN THE FIRST HALF OF real NDATA(IJTH,I) WORD. C C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) C IERR - = 0 NORMAL RETURN C = NON-ZERO FOR ERROR RETURN C IDIXAD(NDIX) ARRAY IS FILLED WITH SUBSCRIPTS OF THE FIRST C ... OBS WITHIN EACH J ROW. C IDIXCO(NDIX) ARRAY IS FILLED WITH THE COUNT OF OBS IN EACH ROW C ... EXCEPT FOR THE LAST ITEM IN IDIXCO ARRAY C ... WHICH CONTAINS THE TOTAL NUMBER OF OBS ... C NDIX IS DIMENSION OF THE TWO ARRAYS ABOVE C .. WHICH SHOULD BE ONE MORE THAN THE TOTAL NUMBER OF C ... J ROWS IN THE GRID... C C REMARK: C CAUTION ... C ... THE FIRST ENCOUNTER WITH AN NDATA(IJTH,I) WORD WHICH IS ALL C ... ZERO WILL BE INTERPRETED AS SIGNALLING THE END OF DATA. C C C ATTRIBUTES: C LANGUAGE: cray fortran 90 C MACHINE: CRAY4 C C$$$ C integer NDATA(ITM,JTM) DIMENSION IDIXAD(NDIX),IDIXCO(NDIX) C ... ARRAYS DIMENSIONED ONE MORE THAN NO OF JROWS IN GRID, BECAUSE C ... THE TOTAL NO OF OBS IS RETURNED IN IDIXCO(NJROWS+1) INTEGER IJWD(2) data iscal4 / x'0000000100000000' / data mask12 / x'ffffffff00000000' / data mask22 / x'00000000ffffffff' / save C C . . . S T A R T . . . c IERR = 0 NJROWS = NDIX - 1 IF(MSKJJ .EQ. 0) GO TO 900 c C ... TO DETERMINE THE SHIFT COUNT TO MAKE THE JGRID AN INTEGER C ... RIGHT-JUSTIFIED. c ISHFCT = 0 MSKBIT = 1 DO I = 1,32 IACC = IAND(MSKJJ,MSKBIT) IF(IACC .NE. 0) GO TO 140 ISHFCT = ISHFCT + 1 MSKBIT = ISHFT(MSKBIT,1) enddo GO TO 900 C 140 CONTINUE IJADR = 1 ISWITA = 0 DO I = 1,NDIX IDIXAD(I) = 0 IDIXCO(I) = 0 enddo NSTRIP = 0 JCURR = 1 c C ... LUPA ... c I = 1 307 CONTINUE ijwd(1) = iand(ndata(ijth,i),mask12)/iscal4 ijwd(2) = iand(ndata(ijth,i),mask22) IF(IJWD(1) .NE. 0) GO TO 311 IF(IJWD(2) .NE. 0) GO TO 311 c C ... OTHERWISE, THE RIJWD WAS .EQ. 0 ... c ISWITA = 1 c C ... NO MORE OBS c GO TO 333 311 CONTINUE JSTN = IAND(IJWD(1),MSKJJ) JSTN = ISHFT(JSTN,-ISHFCT) 314 CONTINUE IF(JCURR .LT. JSTN) GO TO 333 NSTRIP = NSTRIP + 1 c C ... WHICH INCREMENTS COUNT OF OBS W/I THIS J STRIP c I = I + 1 IF(I .LE. JTM) GO TO 307 c C ... OTHERWISE, REACHED END OF FULL BIN, NO MORE OBS ... c ISWITA = 1 333 CONTINUE IDIXAD(JCURR) = IJADR c C ... WHERE IDIXAD HAS SUBSCRIPT FOR FIRST OBS W/I THIS ROW ... c IJADR = IJADR + NSTRIP IDIXCO(JCURR) = NSTRIP c C ... WHERE IDIXCO HAS COUNT OF OBS IN THIS STRIP c NSTRIP = 0 JCURR = JCURR + 1 IF(JCURR .GT. NJROWS) GO TO 355 IF(ISWITA .NE. 0) GO TO 333 GO TO 314 c C ... THE ENDING ... c 355 CONTINUE IDIXCO(NJROWS + 1) = IJADR - 1 c C ... WHICH WOULD BE TOTAL NO OF OBS ... c GO TO 999 C 900 CONTINUE C ... COMES HERE IF GIVEN MSKJJ WAS NO GOOD (WAS ZERO) IEXIT = 1 999 CONTINUE RETURN END c********************************************************************* SUBROUTINE FILFIJ(iADATA,ITM,JTM,NBEFOR,FIJDAT,MCOUNT) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: FILFIJ TO FILL FIJDATA ARRAY WITH ANALYSIS INPUT C PRGMMR: WOBUS ORG: W/NP20 DATE: 97-01-24 C C ABSTRACT: TO FILL JIJDAT ARRAY WITH ANALYSIS INPUT FROM THE GIVEN C ADATA INFOMATION. ALSO CHANGES FROM GRIDI/GRIDJ TO A FINER C MESH COORDINATE. C C PROGRAM HISTORY LOG: C 80-04-01 UNKOWN C 94-01-04 LUKE LIN CONVERT IT FORTRAN 77 AND ADD DOC BLOCK. C 97-01-24 RICHARD WOBUS - CONVERT TO CRAY c 98-05-28 chris caruso removed cdir$ integer=64 from top c of this s/r for f90. C C USAGE: CALL FILFIJ(IADATA,ITM,JTM,NBEFOR,FIJDAT,MCOUNT) C INPUT ARGUMENT LIST: C IADATA - INPUT DATA FIELD C ITM,JTM - DIMENSION OF THE INPUT DATA FIELD. C C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) C FIJDAT - OUTPUT DATA FIELD. C MCOUNT - COUNT FOR DATA. C C ATTRIBUTES: C LANGUAGE: cray fortran 90 C MACHINE: CRAY4 C C$$$ C integer iADATA(ITM,JTM) REAL FIJDAT(3,JTM) integer iRPT(5) real FRPT(10) C DATA ORIGI / 1.0 / DATA ORIGJ / 1.0 / c data iscal2 / x'0000000000010000' / data iscal4 / x'0000000100000000' / data mask12 / x'ffffffff00000000' / data mask22 / x'00000000ffffffff' / data mask34 / x'00000000ffff0000' / data mask44 / x'000000000000ffff' / save C scale = 1.0 / 65536.0 MCOUNT = 0 JOK = 0 DO 266 JJ = 1,JTM IF(JJ .GT. NBEFOR) GO TO 269 DO I = 1,ITM iRPT(I) = iADATA(I,JJ) enddo IF(iRPT(1) .EQ. 0) GO TO 269 iprior = iand(irpt(2),mask34)/iscal2 IF(IPRIOR .LE. 0) GO TO 255 IF(IPRIOR .GT. 3) GO TO 255 c C ... THE ONLY ONES WHICH GET THRU ARE IPRIOR=1,2,OR 3 ... c JOK = JOK + 1 IF(JOK .GT. JTM) GO TO 269 c C ... THIS JJTH REPORT IS A GOOD ONE FOR REFORMATTING c gridi = (iand(irpt(1),mask12)/iscal4)*scale RELIG = GRIDI - 1.0 RELIFM = 2.0 * RELIG FIJDAT(1,JOK) = RELIFM + ORIGI C gridj = (iand(irpt(1),mask22)) * scale RELJG = GRIDJ - 1.0 RELJFM = 2*RELJG FIJDAT(2,JOK) = RELJFM + ORIGJ C icat = iand(irpt(2),mask44) XDATA = 0.1 c C ... SET DEFAULT VALUE TO VFR ... c IF(ICAT .EQ. 1) XDATA = 2.2 IF(ICAT .EQ. 2) XDATA = 1.0 IF(ICAT .EQ. 0) XDATA = 0.1 FIJDAT(3,JOK) = XDATA c C ... WHICH TRANSFERRED ONE OBS TO FIJDAT ... c GO TO 266 255 CONTINUE c C ... COMES HERE IF A 'TOSSED' ONE C ... IF YOU WANT TO PRINT SOMETHING, DO IT HERE ... C 266 CONTINUE 269 CONTINUE MCOUNT = JOK JOK = JOK + 1 IF(JOK .GT. JTM) GO TO 999 c C ... TO ADD A ZERO ITEM AT END AFTER DATA c DO I = 1,3 FIJDAT(I,JOK) = 0 enddo 999 CONTINUE RETURN END c********************************************************************* SUBROUTINE IJAREA(RLAT,RLNG,ICTR,JCTR,LRTN) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: IJAREA CONVERT LAT/LONG OF DATA POINT TO MAP I/J C PRGMMR: WOBUS ORG: W/NP20 DATE: 97-01-24 C C ABSTRACT: GIVEN THE LAT/LONG OF A GIVEN DATA POINT CHECK TO SEE IF C THE POINT IS WITHIN LIMITS FOR THIS MAP. IF SO CONVERT TO I/J C IN DOTS ON THIS MAP BACKGROUND. THIS SUBR USED ONLY FOR C THE US SECTIONAL AT 1/13,333,333. C C PROGRAM HISTORY LOG: C 91-09-11 ORIGINAL AUTHOR HENRICHSEN. C 93-01-06 LUKE LIN CONVERT TO 77. C 96-09-23 SHIMOMURA CONVERT TO CRAY C 97-01-24 RICHARD WOBUS - RELAX BOUNDARY TESTS c 98-05-28 chris caruso removed cdir$ integer=64 from top c of this s/r for f90. C C USAGE: CALL IJAREA(RLAT,RLNG,ICTR,JCTR,LRTN) C INPUT ARGUMENT LIST: C RLAT - real LAT OF POINT. C RLNG - real LON OF POINT. C C OUTPUT ARGUMENT LIST: C ICTR - integer I LOCATION IN DOTS ON MAP. C JCTR - integer J LOCATION IN DOTS ON MAP. C LRTN - logical FLAG SET TO .TRUE. IF POINT IS WITH IN C - MAP BACKGROUND AREA. C ERRFLAG - EVEN IF MANY LINES ARE NEEDED C C C OUTPUT FILES: C FT06F001 - PRINT FILE. C C REMARKS: DETERMINE AREA FOR PLOTTING - NORTH AMERICA...INCLUDES ONLY C SOUTHERN CANADA AND NORTHERN MEXICO. C CALLS ON TRUIJX() C C ATTRIBUTES: C LANGUAGE: FORTRAN 90 C MACHINE: CRAY C C$$$ C real CORNI DATA CORNI / -1.0 / real CORNJ DATA CORNJ / -4.0 / C ...WHERE CORNI,CORNJ MOVES ORIGIN FROM KEIL=13'S GRID C ... ONE LFM GRID INT RIGHT AND 4 INT UPWARD real SCALE C DATA SCALE / 56.25 / !... pxls per grid intvl DATA SCALE / 54.00 / !... pxls per grid intvl C ... was /54.00/ which seems erroneous for dotsgi; chgd 96-09-23 real XELONG DATA XELONG /055.00/ real XWLONG DATA XWLONG /140.00/ real YNLAT DATA YNLAT /060.00/ real YSLAT DATA YSLAT /015.00/ C integer KEIL DATA KEIL /13/ C ... FOR US SECTIONAL AT 1/13,333,333 C integer iret_tij logical LRTN C SAVE c C ... INITIALIZE RESULTS TO SOME INNOCUOUS VALUE ... c ICNTR = 1 JCNTR = 100 LRTN = .FALSE. c C PLOT AREA CHECK... c IF(RLAT.GT.YNLAT) GO TO 900 IF(RLAT.LT.YSLAT) GO TO 900 IF(RLNG.LT.XELONG) GO TO 900 IF(RLNG.GT.XWLONG) GO TO 900 C C CONVERT LAT/LONG TO I/J DOT VALUES... c CALL TRUIJX(RLAT,RLNG,XI,XJ,KEIL,iret_tij) if(iret_tij .NE. 0) then LRTN = .FALSE. GO TO 999 ENDIF GRIDI = XI + CORNI GRIDJ = XJ + CORNJ C C CENTER COORDINATES OF STATION CIRCLE WRT I & J DOT VALUES... C ICTR = NINT((GRIDI-1.0)*SCALE) JCTR = NINT((GRIDJ-1.0)*SCALE) C c return to fixed dot limits C IF(ICTR.LT.0050 .OR. ICTR.GT.1950) GO TO 900 IF(JCTR.LT.0010 .OR. JCTR.GT.1240) GO TO 900 C C SET FLAG FOR GOOD RETURN... C LRTN =.TRUE. GO TO 999 C 900 CONTINUE C C ... LAT OR LONG EXCEEDS GIVEN LIMITS... C LRTN =.FALSE. GO TO 999 999 RETURN END c********************************************************************* SUBROUTINE iniAFBIN(LUNAFOS,COMMSHDR,GPDHEADR,DOTSINCH,IRET_INI) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: INIAFBIN PUT AFOS GRAPHIC PRODUCT DEF TO LBLOCK C PRGMMR: SHIMOMURA ORG: W/NP12 DATE: 97-02-11 C C ABSTRACT: INITIALIZE THE AFOS PRODUCT WORK BIN AND PUT THE AFOS C GRAPHIC PRODUCT DEFINITION BLOCK INTO THE LBLOCK AS THE FIRST C ITEM IN THERE; INITIALIZE VARIOUS OTHER COMMON AREAS IN C PREPARATION FOR THE START OF THE PRODUCT. C C PROGRAM HISTORY LOG: C 95-03-08 ORIGINAL AUTHOR HENRICHSEN C 95-11-13 HENRICHSEN CONVERT TO RUN ON CRAY. c 98-04-22 caruso removed cdir$ integer=64 from top of c this program. C C USAGE: CALL INIAFBIN(lunafos,commshdr,GPDHEADR,dotsinch,IRET_INI) C INPUT ARGUMENT LIST: c lunafos - logical unit number of output file c commshdr - character*(*) communication header c gpdheadr - character*(*) graphics header c dotsinch - real geographic scale (dots per inch) c C OUTPUT ARGUMENT LIST: C IRET_INI - =0, NORMAL c =1, bad logical unit number for lunafos c =2, bad dotsinch value c =3, comms hdr too short c =4, gpd hdr too short c via common: C LBLOCK() - WORK BIN TO HOLD AN ENTIRE AFOS GRAPHIC PRODUCT C C REMARKS: c Removed 'CDIR$ INTEGER=64' from top of this program to get rid c of a cray f90 warning. C C ATTRIBUTES: C LANGUAGE: CRAY FORTRAN 90 C MACHINE: CRAY C C$$$ C C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . INTEGER MAXCNTWRDS !... =2048 LONGWORDS PARAMETER (MAXCNTWRDS=2048) INTEGER MAXCNTBYTS !... =16384 BYTES PARAMETER (MAXCNTBYTS=8*MAXCNTWRDS) C COMMON /ISPACEAF/ LBLOK8,IAFBLOCKCON(10) INTEGER*8 LBLOK8(MAXCNTWRDS) CHARACTER*1 LBLOCK(MAXCNTBYTS) EQUIVALENCE (LBLOK8(1),LBLOCK(1)) integer icntot EQUIVALENCE (IAFBLOCKCON(1),ICNTOT) integer lbnkfg !...NOT USED; BUT KEPT FOR SPACE EQUIVALENCE (IAFBLOCKCON(2),LBNKFG) INTEGER LWORD4 EQUIVALENCE (IAFBLOCKCON(3),LWORD4) INTEGER MAXCNT !... INPUT ARG -- BIN FULL TEST EQUIVALENCE (IAFBLOCKCON(4),MAXCNT) INTEGER NDSRN !... INPUT ARG -- U: AFOS OUT EQUIVALENCE (IAFBLOCKCON(5),NDSRN) C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . COMMON /HDR4AFS/INTCOMHDR,INTGPDHDR, 1 IMAXDOTS,JMAXDOTS, IVYEAR4D,IVMO,IVDA,IVTIME INTEGER INTCOMHDR(3) CHARACTER*24 COMHDR !... NEEDS ONLY 23 EQUIVALENCE (INTCOMHDR(1),COMHDR) INTEGER INTGPDHDR(2) CHARACTER*16 GPDHDR !... NEEDS ONLY 12 EQUIVALENCE (INTGPDHDR(1),GPDHDR) INTEGER IMAXDOTS INTEGER JMAXDOTS INTEGER IVYEAR4D,IVMO,IVDA,IVTIME C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . C THE X,Y LOCATION COMMON / XYLOC / XOLD,YOLD,XNEW,YNEW,SCALE,LPEN,IFIRST INTEGER XOLD,YOLD,XNEW,YNEW REAL SCALE INTEGER LPEN INTEGER IFIRST C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . C THE PRODUCT DEFINITION CONSTANTS COMMON / PRODUK / PI,GS,PDC,ZD,ZT,ZFACT INTEGER PI,GS,PDC,ZD,ZT,ZFACT C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . INTEGER LUNAFOS CHARACTER*(*) COMMSHDR CHARACTER*(*) GPDHEADR REAL DOTSINCH INTEGER IRET_INI C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . INTEGER MSK16B DATA MSK16B / X'0000FFFF' / INTEGER MSK12B DATA MSK12B / X'00000FFF' / INTEGER MSK8B DATA MSK8B / X'000000FF' / INTEGER MSK7B DATA MSK7B / X'0000007F' / INTEGER MSK5B DATA MSK5B / X'0000001F' / INTEGER MSK4B DATA MSK4B / X'0000000F' / INTEGER IACC SAVE IRET_INI = 0 ndsrn = lunafos IF(LUNAFOS .LE. 0 .OR. LUNAFOS .GT. 100) THEN WRITE(6,115)LUNAFOS 115 FORMAT('INIAFBIN: FAILED ON GIVEN AFOS OUTPUT UNIT NO. =', 1 I4,'; WHICH IS UNACCEPTABLE') IRET_INI = 1 GO TO 999 ENDIF maxcnt = MAXCNTBYTS LWORD4 = 0 ICNTOT = 0 C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . C ... to initialize /xyloc/ used by zplot ... XOLD = 0 !... /xyloc/(1) YOLD = 0 !... /xyloc/(2) XNEW = 0 !... /xyloc/(3) YNEW = 0 !... /xyloc/(4) SCALE = dotsinch !... /xyloc/(5) LPEN = 3 !... /xyloc/(6) IFIRST = 0 !... /xyloc/(7) IF(DOTSINCH .LT. 0.0001) THEN C ... SOMETHINGS WRONG WITH THE GIVEN SCALE FACTOR WRITE(6,125) DOTSINCH 125 FORMAT('INIAFBIN: FAILED ON GIVEN SCALE FACTOR FOR ', 1 'DOTS-PER-INCH =',E12.4) IRET_INI = 2 GO TO 999 ENDIF C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . C ... CLEAR THE FIRST AFOS BIN SPACE ... DO I = 1,32 !... 32 LONGWORDS = 256 BYTES LBLOK8(I) = 0 ENDDO C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . DO I = 1,3 INTCOMHDR(I) = 0 ENDDO DO I = 1,2 INTGPDHDR(I) = 0 ENDDO LENCOMM = LEN(COMMSHDR) LENGPD = LEN(GPDHEADR) IF(LENCOMM .LT. 23) THEN WRITE(6,135)LENCOMM 135 FORMAT('INIAFBIN: FAILED ON GIVEN COMMSHDR LENGTH=',I4, 1 '; WHICH MUST BE AT LEAST 23 BYTES') IRET_INI = 3 GO TO 999 ENDIF IF(LENGPD .LT. 12) THEN WRITE(6,145)LENGPD 145 FORMAT('INIAFBIN: FAILED ON GIVEN GPDHEADR LENGTH=',I4, 1 '; WHICH MUST BE AT LEAST 12 BYTES') IRET_INI = 4 GO TO 999 ENDIF COMHDR(1:23) = COMMSHDR(1:23) GPDHDR(1:12) = GPDHEADR(1:12) IACC = INTGPDHDR(1) JMAXDOTS = IAND(IACC,MSK16B) IMAXDOTS = IAND(ISHFT(IACC,-16),MSK16B) C ... THE PRODUCT DEFINITION CONSTANTS ... C * * * C COMMON / PRODUK / PI,GS,PDC,ZD,ZT,ZFACT C INTEGER PI,GS,PDC,ZD,ZT,ZFACT C ... IN THE OLD CODE THE INFO WENT IN THE COMMON AREA FIRST C ... FROM WHICH THE HEADER WAS DERIVED; BUT IN THIS VERSION C ... THE HEADER IS GIVEN TO ME ALREADY MADE; SO I AM FILLING C ... THE /PRODUK/ ITEMS TO BE SURE THE CONSTANTS WILL BE DEFINED C ... IN CASE SOME MEMBER REFERENCES THESE. IACC = INTGPDHDR(1) IACC = ISHFT(IACC,-32) GS = IAND(IACC,MSK16B) IACC = ISHFT(IACC,-16) PI = IAND(IACC,MSK8B) IACC = INTGPDHDR(2) IACC = ISHFT(IACC,-32) PDC = IAND(IACC,MSK4B) IVTIME = IAND(ISHFT(IACC,-4),MSK12B) IACC = ISHFT(IACC,-16) IVYR2D = IAND(IACC,MSK7B) IF(IVYR2D .LT. 98) THEN ivyrcor = 2000 ELSE IVYrcor = 1900 ENDIF IVYEAR4D = IVYR2D + ivyrcor IACC = ISHFT(IACC,-7) IVMO = IAND(IACC,MSK4B) IACC = ISHFT(IACC,-4) IVDA = IAND(IACC,MSK5B) C ... INTEGER IVYEAR4D,IVMO,IVDA,IVTIME ZD = 0 ZT = 0 ZFACT = 0 WRITE(6,165)PI,GS,IMAXDOTS,JMAXDOTS,IVYEAR4D,IVMO,IVDA,IVTIME 165 FORMAT('INIAFBIN: THE GIVEN GPD-HEADER CONTAINED:', 1 /,7X,'PI=',I5,'; GS=',I7,'; IMAX,JMAX= ',I7,',',I7, 2 /,7X,'VALID DATE/TIME=',I5,'-',I2,'-',I2,':',I5,'Z') C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . c C STORE GRAPHIC PRODUCT DEFINITION HEADER INTO LBLOCK C DO I = 1,12 ICNTOT = ICNTOT + 1 LBLOCK(ICNTOT) = GPDHEADR(I:I) ENDDO C WRITE(6,215) COMMSHDR(8:16) 215 FORMAT('INIAFBIN: INITIALIZING /ISPACEAF/ FOR AFOS ', 1 'PRODUCT: ',A9) WRITE(6,8000) ICNTOT 8000 FORMAT(/10X,'INIAFBIN: ICNTOT = ',I5) C WRITE(6,9000) 9000 FORMAT('INIAFBIN: MOVED 12-BYTE GPDHEADR INTO LBLOCK:') WRITE(6,9010) (LBLOK8(II),II=1,2) 9010 FORMAT(1X,Z16,1X,Z16) C 999 continue RETURN END c********************************************************************* SUBROUTINE INTERP (FLD,ID,JD,HI,STI,STJ,KQUAD) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: INTERP INTERPOLATE THE INPUT FIELD C PRGMMR: WOBUS ORG: W/NP20 DATE: 97-01-24 C C ABSTRACT: TO INTERPOLATE THE INPUT FIELD. C C PROGRAM HISTORY LOG: C 80-04-01 UNKNOWN C 94-01-04 LUKE LIN CONVERT IT FORTRAN 77 AND ADD DOC BLOCK. C 97-01-24 RICHARD WOBUS - CONVERT TO CRAY c 98-05-28 chris caruso removed cdir$ integer=64 from top c of this s/r for f90. C C USAGE: CALL INTERP(FLD,ID,JD,JI,STI,STJ,KQUAD) C INPUT ARGUMENT LIST: C FLD - INPUT FIELD. C ID,JD - DIMENSION OF FLD. C C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) C ERRFLAG - EVEN IF MANY LINES ARE NEEDED C C C ATTRIBUTES: C LANGUAGE: cray fortran 90 C MACHINE: CRAY4 C C$$$ DIMENSION FLD(ID,JD) DIMENSION ERAS(4) save I = STI J = STJ if (i.lt.1) then i = 1 endif if (j.lt.1) then j = 1 endif if (i.ge.id) then i = id - 1 endif if (j.ge.jd) then j = jd - 1 endif FI = I FJ = J XDELI = STI - FI XDELJ = STJ - FJ if(kquad.eq.1) then DI = (FLD(I+1,J) + FLD(I+1,J+1) + FLD(I,J+1))/3. elseif(kquad.eq.2) then DI = (FLD(I,J) + FLD(I,J+1) + FLD(I+1,J+1))/3. elseif(kquad.eq.3) then DI = (FLD(I,J) + FLD(I+1,J) + FLD(I,J+1))/3. elseif(kquad.eq.4) then DI = (FLD(I,J) + FLD(I+1,J) + FLD(I+1,J+1))/3. elseif(kquad.eq.5) then ERAS(1) = FLD(I,J) ERAS(4) = FLD(I,J+1) ERAS(2) = ERAS(1) + (FLD(I+1,J) - ERAS(1)) * XDELI ERAS(3) = ERAS(4) + (FLD(I+1,J+1) - ERAS(4)) * XDELI DI = ERAS(2) + (ERAS(3) - ERAS(2)) * XDELJ elseif(kquad.eq.6) then XI2TM = XDELI * (XDELI - 1.) * .25 XJ2TM = XDELJ * (XDELJ - 1.) * .25 J1 = J - 1 DO K = 1,4 ERAS(K) = (FLD(I+1,J1) - FLD(I,J1)) * XDELI + FLD(I,J1) + * (FLD(I-1,J1) - FLD(I,J1) - FLD(I+1,J1) + FLD(I+2,J1)) * * XI2TM J1 = J1 + 1 enddo DI = ERAS(2) + (ERAS(3) - ERAS(2)) * XDELJ + * (ERAS(1) - ERAS(2) - ERAS(3) + ERAS(4)) * XJ2TM endif HI = DI RETURN END c********************************************************************* SUBROUTINE MERGXX(INFILE, outfile) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: MERGXX MERGES & READS A PASSED LABEL FILE. C PRGMMR: WOBUS ORG: W/NP20 DATE: 97-01-24 C C ABSTRACT: MERGES A PASSED LABEL FILE INTO A NEW FILE. C C PROGRAM HISTORY LOG: C 79-MM-DD ORIGINAL AUTHOR HENRICHSEN. C 86-06-30 HENRICHSEN REMOVE ASYNCHRONOUS I/O. C 89-06-29 HENRICHSEN ADD DOC BLOCK. C 94-01-04 LUKE LIN; CONVERT IT TO FORTRAN 77. C 97-01-24 RICHARD WOBUS - CONVERT TO CRAY, NON-DATE-CHECK VERSION C OF MERG55 c 98-05-28 chris caruso removed cdir$ integer=64 from top c of this s/r for f90. C C USAGE: CALL MERGXX(INFILE,outfile) C INPUT ARGUMENT LIST: C INFILE - INTEGER FILE NUMBER OF FILE TO READ. C OUTFILE - INTEGER FILE NUMBER OF FILE TO WRITE. C C OUTPUT ARGUMENT LIST: c none C C INPUT FILES: C Fort.XX - LABEL FILE WHERE XX IS INFILE NUMBER. C C OUTPUT FILES: C Fort.55 - OUTPUT LABEL FILE. C C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION C THIS SUBROUTINE MODIFIED BY PETER HENRICHSEN 30 JUN 1986 TO . C TO REMOVE THE ASYNCHRONOUS IO AND TO REMOVE THE PRINT. C THIS SUBROUTINE WILL MERGE A PASSED LABEL FILE INTO A NEW ONE C IF IFLAG IS NEG ONLY THE 50 WORD IDREC FROM MFILE IS WRITTEN C INTO IDRA IN COMMON/KPLOT/....KRTN IS -1 ..... C IF IFLAG IS POS AND NE 0 THE TIMES PASSED IN CALLING ARGUEMENTS C ARE COMPAIRED AGAINST THOSE FOUND IN THE ID RECORD OF PASSED C FILE...IF A MATCH IS FOUND THE LABEL ARRAY IS MERGED,KRTN = 0 C ...IF NO MATCH IS FOUND LABEL ARRAY IS NOT MERGED ,KRTN = 1 C IF IFLAG IS 0 NO TIME CHECKING IS DONE. LABEL ARRAY IS MERGED C KRTN = 0........... C C ATTRIBUTES: C LANGUAGE: cray fortran 90 C MACHINE: CRAY4 C C$$$ C parameter (narr=1024) INTEGER LEND CHARACTER*8 cend EQUIVALENCE (LEND,CEND) DATA CEND / 'LENDLEND' / data msksork /x'ffffffff'/ data minus7 /x'fffffff9'/ integer iarray(narr) integer infile, outfile save write(6,'('' begin to run mergxx for unit'',i12)') infile ktot = 0 kgood = 0 kerr = 0 kzero = 0 keof = 0 276 continue read(infile,end=778,err=558) iarray kgood = kgood + 1 go to 567 558 continue kerr = kerr + 1 567 continue iskip = 0 iskipa = 1 iarrt = iarray(1) jsork = iand((ishft(iarrt,-32)),msksork) if (jsork .eq. minus7) then iskip = 1 keof = keof + 1 else iskipa = 0 do i = 1,narr if(iarray(i).eq.0) then iarray(i) = 65537 kzero = kzero + 1 iskip = 1 endif enddo endif if(iskipa.eq.0) then write(outfile) iarray ktot = ktot + 1 endif go to 276 778 continue write(6,'('' mergxx records: tot, good, err, zero, eof'',5i6)') , ktot,kgood,kerr,kzero,keof write(6,'('' end of run mergxx for unit'',i12)') infile return end c********************************************************************* SUBROUTINE MKCHDR(indicator,JDATE,IHD1,GOOD1,NGOOD,IHD3) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: MKCHDR MAKE THE AFOS COMMUNICATIONS HEADER. C PRGMMR: LUKE LIN ORG: W/NMC41 DATE: 95-02-03 C C ABSTRACT: GIVEN THE AFOS PRODUCT PIL, PIORITY AND ADDRESS, CREATE C THE COMMUNICATIONS HEADER ARRAY. C C PROGRAM HISTORY LOG: C 94-09-30 ORIGINAL AUTHOR HENRICHSEN C 94-12-23 LUKE LIN CONVERT IT TO CFT-77 C 95-01-20 LUKE LIN CHANGE I/O FORMAT Z3 TO A1 C 95-02-03 LUKE LIN CORRECT PIL NUMBER c 98-05-28 c. caruso add input argument indicator and make jdate c a 4 dimension int array instead of old c packed nmc dateword, in order to pass a c 4 digit year. C C USAGE: CALL MKCHDR(indicator,JDATE,IHD1,GOOD1,NGOOD,IHD3) C INPUT ARGUMENT LIST: C JDATE - INTEGER 4 element array. IF NOT EQUAL TO ZERO, WILL C - contain the BASE DATE THAT WILL BE USED TO MAKE C - COMMUNICATIONS HEADER, OTHERWISE THE SYSTEMS C - TIME WILL BE USED. jdate is 4 digit year, month, c - day, hour C IHD1 - CHARACTER*10 ARRAY THAT CONTAINS THE FOLLOWING: C - IHD1(1:3) AFOS PIL NUMBER IN ASCII. C - IHD1(4:6) AFOS PIL NUMBER IN ASCII. C - IHD1(07:07) INTEGER AFOS PIORITY. C - IHD1(10:10) INTEGER PRODUCT ADDRESS. C GOOD1 - CHARACTER*200 ARRAY THAT CONTAINS NAMES OF THE C - PRODUCTS COMPLETED. C NGOOD - INTEGER*4 NUMBER OF PRODUCTS COMPLETED. C C OUTPUT ARGUMENT LIST: C IHD3 - CHARACTER*23 ARRAY THAT CONTAINS THE FOLLOWING: C - IHD3(5:5) INTEGER PRODUCT ADDRESS. C - IHD3(7:7) INTEGER AFOS PIORITY. C - IHD3(14:16) AFOS PIL NUMBER IN ASCII. C - IHD3(17:19) PRODUCT CREATION TIME. C - IHD3(20:21) PRODUCT CREATION TIME (DELTA TAU) C GOOD1 - CHARACTER*200 ARRAY THAT CONTAINS NAMES OF THE C - PRODUCTS COMPLETED. C NGOOD - INTEGER*4 NUMBER OF PRODUCTS COMPLETED. C C C OUTPUT FILES: C FT06F001 - PRINT FILE. C C ATTRIBUTES: C LANGUAGE: Cray fortran 90 C MACHINE: CRAY C C$$$ C CHARACTER*200 GOOD1 CHARACTER*23 CIHD3 CHARACTER*23 IHD3 CHARACTER*24 KHD3 CHARACTER*10 IHD1 CHARACTER*4 BLANK CHARACTER*4 CHPIL INTEGER LIHD3(3) INTEGER KHEDER(3) C INTEGER IDAT(8) integer ivldat(8) integer jdate(4) integer indicator C EQUIVALENCE (LIHD3(1),CIHD3) EQUIVALENCE (KHEDER(1),KHD3) C DATA LIHD3 1 /Z'010040007F00004E',Z'4D43475048000000', 2 Z'0000000000000000'/ DATA BLANK /' '/ save C IF(NGOOD.LT.0) THEN NGOOD = 0 ELSEIF(NGOOD.GT.50) THEN WRITE(6,FMT='('' MKCHDR:'',I3,'' MAPS GREATER THAN OR EQ'', 1 ''UAL TO THHE LIMIT OF "50" MAPS!. THEREFORE WILL START'', 2 '' OVER AGAIN BY SETTING NGOOD TO "00" MAPS!. '')')NGOOD NGOOD = 0 ELSE ENDIF ISTART = NGOOD * 4 + 1 IEND = ISTART + 3 CHPIL = BLANK C C INITIALIZE IHD3 ARRAY. C IHD3(1:23) = CIHD3(1:23) C C LOAD PRODUCT ADDRESS IN BYTE 5 OF COMMS HEADER ARRAY. C IHD3(5:5) = IHD1(10:10) C C LOAD PRODUCT PIORITY IN BYTE 7 OF COMMS HEADER ARRAY. C IHD3(7:7) = IHD1(7:7) C C LOAD PRODUCT PIL IN BYTES 14-16. C IHD3(14:16) = IHD1(1:3) C C LOAD PRODUCT PIL IN GOOD1 ARRAY. C CHPIL(1:3) = IHD1(4:6) GOOD1(ISTART:IEND) = CHPIL(1:4) NGOOD = NGOOD + 1 C call w3utcdat(idat) IF(indicator.EQ.0)THEN C C GET GREENWICH (UTC) TIME FOR COMMS HEADER. C WRITE(6,FMT='('' MKCHDR: MAKING COMMS HEADER WITH '', 1 ''CURRENT TIME!'')') ICYCLT = 0 print *,' idat=',(idat(i),i=1,8) IMO = IDAT(3) IDA = IDAT(4) c C JDY IS THE DAY OF THE YEAR(1-366) c call w3doxdat(idat,jdow,jdoy,jday) JDY = jdoy - 1 WRITE(6,FMT='('' MKCHDR: JDY ='',I4)')JDY IHR = IDAT(5) print *,' imo,ida,jdy,ihr=', imo,ida,jdy,ihr C C NOW IHR IS THE HOUR OF THE DAY C ELSE WRITE(6,FMT='('' MKCHDR: MAKING COMMS HEADER WITH '', 1 ''BASE TIME!'')') iyr4d = jdate(1) imo = jdate(2) kday = jdate(3) ihr = jdate(4) print*,' using valid time in mkchdr' print*,' iyr4d = ',iyr4d,' imo = ',imo,' kday = ',kday print*,' ihr = ',ihr ivldat(1) = iyr4d ivldat(2) = imo ivldat(3) = kday ivldat(4) = idat(4) ivldat(5) = ihr ivldat(6) = 0 ivldat(7) = 0 ivldat(8) = 0 call w3doxdat(ivldat,jdow,jdoy,jday) jdy = jdoy - 1 print *,' after w3doxdat...jdy=', jdy print *,' imo,jdy,ihr=', imo,jdy,ihr ENDIF JCREAT = 1440 * JDY + 60 * IHR C C NOW WE HAVE JCREAT THAT IS CREATION TIME IN ELAPSED C MINUTES FROM START OF YEAR C ICR = JCREAT/16384 IHD3(17:17) = CHAR(ICR) IREM = MOD(JCREAT,16384) ICR = IREM/128 IHD3(18:18) = CHAR(ICR) IREM = MOD(IREM,128) IHD3(19:19) = CHAR(IREM) C C COMPLETED WITH CREATION TIME. C NOW DO DELTA TIME C JTAU = 0 c C THIS IS THE PATCH ZERO OUT DELTA-T IN COMMS. HEADER c JDELTA = 60 * JTAU c C JDELTA IS DELTA TIME IN MINUTES c IDL = JDELTA/128 IHD3(20:20) = CHAR(IDL) IREM = MOD(JDELTA,128) IHD3(21:21) = CHAR(IREM) print *,' jdelta,idl,irem=', jdelta, idl, irem C KHD3(1:23) = IHD3(1:23) WRITE(6,FMT='('' MKCHDR: MADE COMMS HEADER = '',3Z16)') 1(KHEDER(II),II=1,3) RETURN END c********************************************************************* SUBROUTINE MK_GHDR(KDATE,GEOSCAL,IMAX,JMAX,PRJIND,GPDHEADR, * IRETN) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: MK_GHDR MAKE THE AFOS GRAPHIC PRODUCT DEFINITION. C PRGMMR: SHIMOMURA ORG: W/NP12 DATE: 97-02-11 C C ABSTRACT: MAKE THE AFOS UGF GRAPHIC PRODUCT DEFINITION HEADER; BUT C DOES NOT PUT THE RESULTING HEADER INTO LBLOCK. C C PROGRAM HISTORY LOG: C 95-03-08 ORIGINAL AUTHOR HENRICHSEN C 95-11-13 HENRICHSEN CONVERT TO RUN ON CRAY. C 97-02-11 SHIMOMURA -- ADAPTING MKGHDR() TO MY COMMON DEF; C RENAMED TO "MK_GHDR"; SPLIT OFF THE PUTTING C OF THE RESULTING GPDHEADR TO SOME OTHER C FUNCTION -- LIKE INIAFBIN() c 98-04-22 caruso removed cdir$ integer=64 from top of c this program. c 98-04-30 caruso changed input argument kdate from being c o.n. 84 packed nmc dateword to 4 element c integer array with 4 digit year, month, c day, and hour. c 98-06-19 chris caruso - extend common ispaceaf to equal length c of that common in s/r iniafbin C C USAGE: CALL MK_GHDR(KDATE,GEOSCAL,IMAX,JMAX,PRJIND,IRETN) C INPUT ARGUMENT LIST: C KDATE - INTEGER array of 4 elements containing 4 digit year, c - month, day, hour. Formerly, was nmc dateword THAT HAD c - THE VALID YEAR, MONTH, DAY AND HOUR IN PACKED C - FORM LIKE WORD 7 OF AN O.N. 84 PACKED FIELD ID. C GEOSCAL - INTEGER GEOGRAPHY SCALE VALUE. C IMAX - INTEGER SIZE OF PRODUCT IN I DIRECTION (DOTS) C JMAX - INTEGER SIZE OF PRODUCT IN J DIRECTION (DOTS) C PRJIND - INTEGER FLAG DEFINING WHAT MAP PROJECTION TO USE. C C OUTPUT ARGUMENT LIST: C IRETN - =0, NOMAL C =8, PROJECTION INDICATOR NOT ACCEPTABLE C C REMARKS: c Removed 'CDIR$ INTEGER=64' from top of this program to get rid c of a cray f90 warning. C C ATTRIBUTES: C LANGUAGE: CRAY FORTRAN 90 C MACHINE: CRAY C C$$$ C c COMMON/ISPACE/LBLOK8(2048),ICNTOT,LBNKFG,KBLOK8(160) c EQUIVALENCE (LBLOK8(1),LBLOCK(1)) 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 GHEADR(2) CHARACTER*16 CHEADR EQUIVALENCE (GHEADR(1),CHEADR(1:1)) C CHARACTER*12 GPDHEADR !... DESTINATION I*2 (6) C INTEGER GEOSCAL INTEGER KDATE(4) INTEGER NBITS(10) DATA NBITS /8,8,16,16,16,5,4,7,12,4/ INTEGER NOFF(10) DATA NOFF /0,8,16,32,48,64,69,73,80,92/ INTEGER PI(15) DATA PI /5*1,4*100,1,100,4*1/ INTEGER PRJIND INTEGER VALUES(10) INTEGER VDAY INTEGER VHOUR INTEGER VMONTH INTEGER VYEAR2D INTEGER VYEAR4D save C IRETN = 0 LBNKFG = 0 DO I =1,2 GHEADR(I) = 0 ENDDO C C GET THE VALID TIME FROM KDATE C print*,' in mk_ghdr..kdate = ',kdate(1),kdate(2), * kdate(3),kdate(4) vyear4d = kdate(1) vmonth = kdate(2) vday = kdate(3) vhour = kdate(4) vyear2d = mod(vyear4d,100) C WRITE(6,6000)VHOUR,VYEAR2D,VMONTH,VDAY 6000 FORMAT(/5X,'MK_GHDR AFTER unpacking kdate: ', * ' VHOUR = ',I5,' VYEAR2D = ',I5,' VMONTH = ',I5, * ' VDAY = ',I5) C ITIME = 100 * VHOUR C IF (PRJIND.LE.0 .OR. PRJIND.GT.15) THEN c C .. BACKGROUND NOT FOUND c WRITE(6,FMT='('' MK_GHDR: ERROR, GRAPHIC PROJECTION'',I4, 1 '' INDICATOR NOT ACCEPTABLE.'')')PRJIND IRETN = 8 GO TO 999 ENDIF c C ... OTHERWISE, THE PROJECTION INDICATOR IS ACCEPTABLE ... c IND = PRJIND print*,' in mk_ghdr...geoscal = ',geoscal,' prjind = ', * prjind,' pi(ind) = ',pi(ind) C C SET UP GRAPHIC PRODUCT DEFINITION HEADER C VALUES(1) = 193 VALUES(2) = PI(IND) VALUES(3) = GEOSCAL VALUES(4) = IMAX VALUES(5) = JMAX VALUES(6) = VDAY VALUES(7) = VMONTH VALUES(8) = VYEAR2D VALUES(9) = ITIME VALUES(10) = 0 C C ...PUT VALID DATE IN GRAPHIC PROD. DEF. HEADER C DO I = 1,10 CALL SBYTE(GHEADR,VALUES(I),NOFF(I),NBITS(I)) ENDDO C C ... MOVE GRAPHIC PRODUCT DEFINITION INTO GPDHEADER(1:12) C GPDHEADR(1:12) = CHEADR(1:12) WRITE(6,FMT='('' MK_GHDR: GRAPHIC HEADER(1:12)='',2Z16)') 1 (GHEADR(II),II=1,2) 999 CONTINUE RETURN END c********************************************************************* SUBROUTINE NONVIS(INTEXT,NOCHAR,IX,IY,B,RB,ZT,ISIZE,IRETN) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: NONVIS PUT NON VISIBLE TEXT IN AFOS GRAPHIC. C PRGMMR: LUKE LIN ORG: W/NMC41 DATE: 95-01-20 C C ABSTRACT: PUTS NON VISIABLE ASCII TEXT AS THE FIRST ENTRY IN THE C AFOS GRAPHIC AS (MODE C5). THE TEXT IS PASSED IN INTEXT. C TEXT WILL NOT SHOW ON THE GRAPHIC BUT IS USED BY VARIOUS ODD C BALL PROGRAMS IN WESTERN REGION TO GET THE PRODUCT BASE TIME. C C PROGRAM HISTORY LOG: C 94-07-29 ORIGINAL AUTHOR HENRICHSEN C 94-12-23 LUKE LIN CONVERT IT CFT-77. C 95-01-20 LUKE LIN CHANGE I/O FORMAT Z3 TO A1 c 98-06-19 chris caruso - extend common ispaceaf to equal length c of that common in s/r iniafbin C C USAGE: CALL NONVIS(INTEXT,NOCHAR,IX,IY,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 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 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 THIS SUB WAS WRITTEN AT THE REQUEST OF MR DAN BAUMGARDT SO THAT C THE VARIOUS OLD PROGRAMS DO NOT HAVE TO BE CHANGED. 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 INTEGER MODE C INTEGER IMEDIA(3) INTEGER MODEHD C CHARACTER*6 CMEDIA CHARACTER*1 ABLANK CHARACTER*1 INTEXT(NOCHAR) C DATA MODEHD /Z'C540'/ C C CHECK TO SEE IF LBNKFG IS -1 IF .TURE. THE SUBTRACT ONE FROM C ICNTOT AND RESET LBNKFG TO 0. C C?? CHARACTER*1 ABLANK /Z20/ save ABLANK = CHAR(32) C IF(LBNKFG.EQ.-1)THEN ICNTOT = ICNTOT - 1 LBNKFG = 0 ENDIF C IRETN = 0 ISAVE = ICNTOT ITOT = ICNTOT + 6 + NOCHAR NOCH = NOCHAR + 1 IF(ITOT .GT. 16384) THEN IRETN = 5 WRITE(6,FMT='('' MODEC0: 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 . . . TURN ON THE ZOOM THRESHOLD BITS AS REQUIRED. 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) ELSEIF(ZT .EQ. 3) THEN MODE = IBSET(MODE,3) MODE = IBSET(MODE,4) ENDIF ENDIF C C . . . CHECK TO SEE IF RESERVE BLOCK FLAG IS SET C IF( RB.EQ.1) MODE = IBSET(MODE,5) C .... LOAD FIRST WORD .... IMEDIA(1) = MODE C NEWIX = IX NEWIY = IY IF (NEWIX .LE. 0 ) NEWIX = 0 IF (NEWIY .LE. 0 ) NEWIY = 1536 C IF(ISIZE .EQ.2) THEN C C ...... DOUBLING FLAG IS ON TURN ON DOUBLING BITS. C NEWIX = IBSET(NEWIX, 15) NEWIX = IBSET(NEWIX, 14) ENDIF C C .... LOAD I COORDINATE... C IMEDIA(2) = NEWIX C C .... LOAD J COORDINATE... C IMEDIA(3) = NEWIY CALL SBYTES(CMEDIA,IMEDIA,0,16,0,3) C C .... STORE 3 2-BYTE INTEGERS TO 6-CHARACTER ARRAY C DO II = 1,6 ICNTOT = ICNTOT + 1 LBLOCK(ICNTOT) = CMEDIA(II:II) ENDDO WRITE(6,FMT='('' NONVIS: CONTROL IN HEX='', 1 /,06A1)')(CMEDIA(IJ:IJ),IJ=1,6) C C . . . MOVE TEXT FROM INTEXT TO LBLOCK.... C DO I = 1, NOCHAR ICNTOT = ICNTOT +1 LBLOCK(ICNTOT) = INTEXT(I) ENDDO WRITE(6,FMT='('' NONVIS: INVIABLE TITLE IN HEX='', 1 /,44A1)')(INTEXT(IJ),IJ=1,NOCHAR) C C . . . CHECK TO SEE IF NOCHAR IS EVEN..... C IREM = MOD(NOCHAR,2) C . . . CACULATE NUMBER OF HALF WORDS.... IF(IREM.EQ.1) THEN ICNTOT = ICNTOT + 1 LBLOCK(ICNTOT) = ABLANK LBNKFG = - 1 ENDIF RETURN END c********************************************************************* SUBROUTINE SHLSRS(iADATA,ITM,JTM,ISKEY,MSKEYL,MSKEYR,NOBS,IERR) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: SHLSRS PREPARE FOR THE SORTING. C PRGMMR: WOBUS ORG: W/NP20 DATE: 97-01-24 C C ABSTRACT: TO SORT IN PLACE THE GIVEN real ADATA ARAY USING A SIFTING C LOGIC BY SHELL C C PROGRAM HISTORY LOG: C 79-06-01 DAVE SHIMOMURA C 94-01-04 LUKE LIN CONVERT IT FORTRAN 77 AND ADD DOC BLOCK. C 97-01-24 RICHARD WOBUS - CONVERT TO CRAY c 98-05-28 chris caruso removed cdir$ integer=64 from top c of this s/r for f90. C C USAGE: CALL SHLSRS(ADATA,ITM,JTM,ISKEY,MSKEYL,MSKEYR,NOBS,IERR) C INPUT ARGUMENT LIST: C ADATA - GIVEN real ADATA(ITM,JTM) C ITM - I-DIMENSION OF ADATA C ITM IS LIMITED TO .LE. MAXITM AND IF YOU WANT TO INCREASE C THAT DIMENSION CHANGE THE DIMENSION IN RUPR ALSO C JTM - J-DIMENSION OF ADATA. C ISKEY - POINTS TO THE SORT-KEY WORD AMONG THE ITM WORDS C MSKEYL - IS THE .AND. MASK FOR THE SORT KEY FOR THE HI-ORDER C 32 BITS OF ADATA(ISKEY,J) C MSKEYR - IS THE .AND. MASK FOR THE SORT KEY FOR THE LOW-ORDER C 32 BITS OF ADATA(ISKEY,J) C NOBS - NUMBER OF OBSERVATIONS FOUND IN THE ADATA ARRAY C C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) C IERR - = 0 NORMAL RETURN C = NON-ZERO FOR ERROR RETURN C C REMARK: C CAUTION ... AN ALL ZERO WORD IN ADATA(ISKEY,J) WILL BE C ... INTERPRETED AS THE END OF DATA. C C CAUTION ... C ... THIS USES , IN EFFECT, A LOGICAL COMPARE SO THAT C ... A LEADING BIT SUCH AS FOUND IN A NEGATIVE INTEGER C ... WOULD SORT HIGH ... C C ATTRIBUTES: C LANGUAGE: cray fortran 90 C MACHINE: CRAY4 C C$$$ C integer iadata(itm,jtm) integer irupr(5) C INTEGER IFULWD(2) C INTEGER ISORK(4),JSORK(4) C LOGICAL LSAVED C DATA MINOBS / 2 / C ... WHERE MINOBS IS NO. OF ITEMS LESS THAN WHICH I NEED NOT SORT DATA MSKlHS / X'ffff0000' / DATA MSKRHS / X'0000FFFF' / data iscal2 / x'0000000000010000' / data iscal4 / x'0000000100000000' / data iscal6 / x'0001000000000000' / data mask14 / x'ffff000000000000' / data mask24 / x'0000ffff00000000' / data mask34 / x'00000000ffff0000' / data mask44 / x'000000000000ffff' / DATA MAXITM / 5 / save C C . . . S T A R T . . . . . C IERR = 0 IF(ITM .LE. 0) GO TO 900 IF(ITM .GT. MAXITM) GO TO 900 IF(JTM .LE. 0) GO TO 900 IF(ISKEY .LE. 0) GO TO 910 IF(ISKEY .GT. ITM) GO TO 910 C IF(MSKEYL .NE. 0) GO TO 155 IF(MSKEYR .EQ. 0) GO TO 920 155 CONTINUE C C ... TO COUNT THE NO. OF ITEMS IN THE GIVEN ADATA ARRAY, C ... SEARCHING FOR THE FIRST ZERO WORD IN THE SORT-KEY WORD C NOBS = 0 IOBS = 0 DO J = 1,JTM IF(iADATA(ISKEY,J).eq.0) go to 170 IOBS = IOBS + 1 enddo 170 CONTINUE C C ...WHEN IT COMES TO 170, IOBS CONTAINS COUNT OF NON-ZERO ITEMS C NOBS = IOBS IF(NOBS .LE. 0) GO TO 950 IF(NOBS .LT. MINOBS) GO TO 960 C C ... HERE COMES THE SHELL SORT LOGIC ... C INTRVL = NOBS 311 CONTINUE C C ... THE FRANK AND LAZARUS MODIFICATION ... C ...TO ENSURE ODD-NUMBERED INTERVAL; C ...AND ALSO WHEN INTRVL IS LARGE, C ... TO DIVIDE BY APPROX. 4 INSTEAD OF 2 C ... INSTEAD OF INTRVL=INTRVL/2 ....... C IDIV = 4 IF(INTRVL .GT. 15) IDIV = 8 ITEMP = INTRVL / IDIV INTRVL = 2*ITEMP + 1 NMI = NOBS - INTRVL DO 499 JJ = 1,NMI LSAVED = .FALSE. C C ... EXTRACT SORT KEY OF THE UPPER ITEM (,JJ+INTRVL) C ... THIS IS THE COMPARED AGAINST ITEM IN THIS JJ LOOP. C iACC = iADATA(ISKEY,JJ+INTRVL) IFULWD(1) = IAND(iand(IACC,msklhs)/iscal2,MSKEYL) IFULWD(2) = IAND(iand(IACC,mskrhs) ,MSKEYR) iacc = ifulwd(1)*iscal4 + ifulwd(2) DO I = 1,4 if (i.eq.1) mq = iand(iacc,mask14)/iscal6 if (i.eq.2) mq = iand(iacc,mask24)/iscal4 if (i.eq.3) mq = iand(iacc,mask34)/iscal2 if (i.eq.4) mq = iand(iacc,mask44) ISORK(I) = IAND(MQ,MSKRHS) enddo C C ... INNER DO LOOP ON JRUNG GOES BACKWARDS FROM JJ TO 1 BY -INTRVL C JRUNG = JJ 400 CONTINUE C C ... COMPARE THE ITEM ON THIS JRUNG AGAINST RUPR ... C ... EXTRACT SORT KEY OF ITEM ON JRUNG C iACC = iADATA(ISKEY,JRUNG) IFULWD(1) = IAND(iand(IACC,msklhs)/iscal2,MSKEYL) IFULWD(2) = IAND(iand(IACC,mskrhs) ,MSKEYR) iacc = ifulwd(1)*iscal4 + ifulwd(2) DO I = 1,4 if (i.eq.1) mq = iand(iacc,mask14)/iscal6 if (i.eq.2) mq = iand(iacc,mask24)/iscal4 if (i.eq.3) mq = iand(iacc,mask34)/iscal2 if (i.eq.4) mq = iand(iacc,mask44) JSORK(I) = IAND(MQ,MSKRHS) enddo C DO II = 1,4 IF(JSORK(II) - ISORK(II).gt.0) go to 430 IF(JSORK(II) - ISORK(II).lt.0) go to 450 enddo 430 CONTINUE C C ... COMES HERE TO MOVE THIS ITEM (WHICH TESTED AS .GE. RUPR) C ... UPWARDS FROM THIS JRUNG TO THE RUNG ABOVE. C IF(LSAVED) GO TO 440 C C ... OTHERWISE, ORIGINAL UPPER ITEM IN THIS JJ LOOP HAS NOT C ... BEEN SAFELY SAVED IN RUPR YET. C ... SAVE IN RUPR THE (JJ+INTRVL)-TH ITEM C DO I = 1,ITM iRUPR(I) = iADATA(I,JJ+INTRVL) enddo LSAVED = .TRUE. C 440 CONTINUE JRPI = JRUNG + INTRVL DO I = 1,ITM iADATA(I,JRPI) = iADATA(I,JRUNG) enddo JRUNG = JRUNG - INTRVL IF(JRUNG .GE. 1) GO TO 400 C C ... WHICH IS END OF INNER DO LOOP ... C 450 CONTINUE C C ... COMES HERE TO STORE THE ORIGINALLY PULLED OUT ITEM (FROM THE C ... TOP OF THE LADDER) INTO DOWN WHERE THE MOVED UP ONES C ... VACATED A RUNG. C JRPI = JRUNG + INTRVL IF(JRUNG .EQ. JJ) GO TO 499 DO I = 1,ITM iADATA(I,JRPI) = iRUPR(I) enddo 499 CONTINUE C IF(INTRVL .GT. 1) GO TO 311 write(6,'('' in shlsrs: nobs'',i6)') nobs GO TO 999 C C . . . E R R O R E X I T S . . . . . . . C 900 CONTINUE C C ... COMES HERE TO 900 IF DIMENSIONS OF ADATA ARE UNREASONABLE C IERR = 1 GO TO 999 910 CONTINUE C C ... COMES TO 910 IF ISKEY WAS OUT-OF-RANGE C IERR = 2 GO TO 999 920 CONTINUE C C ... COMES TO 920 IF BOTH MSKEYR AND -L ARE ZERO C ... WHICH WOULD ZERO OUT ALL SORT KEY, YIELDING NO SORTING C IERR = 3 GO TO 999 950 CONTINUE C C ... COMES HERE TO 950 IF NO OBS IN GIVEN ADATA FILE C NOBS = 0 IERR = 0 GO TO 999 960 CONTINUE C C ... COMES HERE WHEN ONLY ONE OBS WAS GIVEN IN ADATA ARRAY C IERR = 0 GO TO 999 C 999 CONTINUE RETURN END c********************************************************************* SUBROUTINE TOSOUT(iRDATA,ITM,JTM,IDIXAD,IDIXCO,NDIX, 1 ISETT,DOTSGI) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: TOSOUT A THINNER OF DATA FOR PRE-ANALYSIS C PRGMMR: WOBUS ORG: W/NP20 DATE: 97-01-24 C C ABSTRACT: A THINNER OF DATA FOR PRE-ANALYSIS. C ALSO REFORMATS THE IGRID/JGRID INFO FROM THE GIVEN SORT-KEY C FORMAT OF JJJ/III/IFR/JFR INTO FLOATING WORDS GRIDI/GRIDJ C C PROGRAM HISTORY LOG: C 80-04-01 UNKNOWN C 94-01-04 LUKE LIN CONVERT IT FORTRAN 77 AND ADD DOC BLOCK. C 97-01-24 RICHARD WOBUS - CONVERT TO CRAY c 98-05-28 chris caruso removed cdir$ integer=64 from top c of this s/r for f90. C C USAGE: CALL TOSOUT(IRDATA,ITM,JTM,IDIXAD,IDIXCO,NDIX,ISETT,DOTSGI) C INPUT ARGUMENT LIST: C iRDATA - INPUT DATA FIELD C ITM,JTM - DIMENSION OF THE INPUT DATA FIELD. C DOTSGI - DOTS PER GRID INTERVAL C IDIXAD(NDIX) ARRAY IS FILLED WITH SUBSCRIPTS OF THE FIRST C ... OBS WITHIN EACH J ROW. C IDIXCO(NDIX) ARRAY IS FILLED WITH THE COUNT OF OBS IN EACH ROW C ... EXCEPT FOR THE LAST ITEM IN IDIXCO ARRAY C ... WHICH CONTAINS THE TOTAL NUMBER OF OBS ... C C C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) C NFOUND - NUMBER OF DATA ITEMS FOUND IN INDATA C C ATTRIBUTES: C LANGUAGE: cray fortran 90 C MACHINE: CRAY4 C C$$$ C integer irdata(itm,jtm) DIMENSION IDIXAD(NDIX),IDIXCO(NDIX) REAL RPTA(5) integer irptal(5) equivalence(rpta(1),irptal(1)) INTEGER IRPTA(10) INTEGER IHFRPA(20) REAL FRPTA(10) EQUIVALENCE (RPTA(1),FRPTA(1)) C REAL RPTB(5) integer irptbl(5) equivalence(rptb(1),irptbl(1)) INTEGER IRPTB(10) INTEGER IHFRPB(20) REAL FRPTB(10) EQUIVALENCE (RPTB(1),FRPTB(1)) c integer irptec character*8 crptei equivalence (irptec,crptei) C CHARACTER*1 LCODE CHARACTER*1 LA,LB,LD DATA LA / 'A' / DATA LB / 'B' / DATA LD / 'D' / DATA MXPRTA / 50 / DATA MXPRTB / 50 / DATA VERYCL / 4.0 / data iscal2 / x'0000000000010000' / data iscal4 / x'0000000100000000' / data iscal6 / x'0001000000000000' / data mask12 / x'ffffffff00000000' / data mask22 / x'00000000ffffffff' / data mask14 / x'ffff000000000000' / data mask24 / x'0000ffff00000000' / data mask34 / x'00000000ffff0000' / data mask44 / x'000000000000ffff' / data nask34 / x'ffffffff0000ffff' / save C ... VERY CLOSE = 4 DOTS FOR DUPLICATE STN TEST ... IPRNTA = 0 IPRNTB = 0 SCALE = 1.0 / 65536.0 C C ... CONSTANT FOR SHIFTING BINARY POINT 16 BITS ... C ... WHERE 65536 = 2**16 C IKDOT = ISETT JKDOT = ISETT CLOSE = FLOAT(ISETT) C C ... DEFINE SIZE OF BOX FOR BOX TEST ... C DELIK = FLOAT(IKDOT) / DOTSGI DELJK = FLOAT(JKDOT) / DOTSGI C C ... DEFINE SIZE FOR CIRCLE TEST ... C CLOSSQ = (CLOSE/DOTSGI) * (CLOSE/DOTSGI) VERYSQ = (VERYCL/DOTSGI) * (VERYCL/DOTSGI) NJROWS = NDIX - 1 NOBS = IDIXCO(NDIX) C C ... REFORMAT I/J LOCATION FROM THE GIVEN JJJ/III/IFR/JFR C ... INTO /GRIDI/GRIDJ/ IN real SECTORS ... C DO JJ = 1,JTM IF(JJ .GT. NOBS) GO TO 170 C C ... FETCH I/J OF ONE OBS ... C iRPTAl(1) = iRDATA(1,JJ) ihfrpa(1) = iand(irptal(1),mask14)/iscal6 ihfrpa(2) = iand(irptal(1),mask24)/iscal4 ihfrpa(3) = iand(irptal(1),mask34)/iscal2 ihfrpa(4) = iand(irptal(1),mask44) JHOLD = IHFRPA(1) IHFRPA(1) = IHFRPA(2) IHFRPA(2) = IHFRPA(3) IHFRPA(3) = JHOLD irptal(1) = ior(ior(iand(ihfrpa(1)*iscal6,mask14), 1 iand(ihfrpa(2)*iscal4,mask24)), 2 ior(iand(ihfrpa(3)*iscal2,mask34), 3 iand(ihfrpa(4) ,mask44))) c FRPTA(1) = SCALE * FLOAT(IRPTA(1)) c FRPTA(2) = SCALE * FLOAT(IRPTA(2)) iRDATA(1,JJ) = iRPTAl(1) enddo 170 CONTINUE C C ... THIS IS A TWO-PASS PROCEDURE IN WHICH THE FIRST PASS C ... WILL TOSS OUT OVERLAPS AND 2ND PASS WILL RESTORE ANY C ... 'TOSSED' STATION WHICH WILL FIT WITHOUT OVERLAPS C ... (FROM TOO MUCH TOSSING OUT IN 1ST PASS) C DO 299 NPASS = 1,2 C DO 280 JA = 1,JTM C C ... THIS IS THE TOP OF STN A LOOP ... C IF(JA .GT. NOBS) GO TO 299 DO I = 1,ITM iRPTAl(I) = iRDATA(I,JA) enddo ihfrpa(7)=iand(irptal(2),mask34)/iscal2 IPRIOA = IHFRPA(7) IF(NPASS .EQ. 2) GO TO 208 C C ... OTHERWISE, ASSUME ITS FIRST PASS ... C IF(IPRIOA .LE. 0) GO TO 280 C C ... OTHERWISE, THIS STN A HAS NOT BEEN TOSSED, SO GO ON ... C GO TO 211 208 CONTINUE C C ... 2ND PASS ... C IF(IPRIOA .GT. 0) GO TO 280 C C ... OTHERWISE, THIS IS ONE OF THE 'TOSSED' ONES C ... WHICH I AM LOOKING FOR ... C ... RESET MARKER OF A TO 'NOT-TOSSED' TEMPORARILY ... C IPRIOA = IABS(IPRIOA) 211 CONTINUE c ASTNI = FRPTA(1) c ASTNJ = FRPTA(2) irpta(1)=iand(irptal(1),mask12)/iscal4 irpta(2)=iand(irptal(1),mask22) ASTNI = SCALE * FLOAT(IRPTA(1)) ASTNJ = SCALE * FLOAT(IRPTA(2)) AIRIT = ASTNI + DELIK AILEF = ASTNI - DELIK AJHI = ASTNJ + DELJK AJLO = ASTNJ - DELJK C C ... TRUNCATE TO GRID LINE ... C JLOS = AJLO IF(JLOS .LT. 1) JLOS = 1 JHIS = AJHI IF(JHIS .LT. JLOS) JHIS = JLOS DO 260 JSTRIP = JLOS,JHIS IF(JSTRIP .GT. NJROWS) GO TO 264 NSTRIP = IDIXCO(JSTRIP) C C ... ANY OBS IN THIS STRING? ... C IF(NSTRIP .LE. 0) GO TO 260 JB = IDIXAD(JSTRIP) C C ... WHICH POINTS TO FIRST B-STN IN THIS STRIP ... C DO 255 JBR = 1,NSTRIP IF(JB .EQ. JA) GO TO 250 C C ... WHICH TESTED FOR ITSELF ... C ... OTHERWISE, FETCH STN B ... C DO I = 1,ITM iRPTBl(I) = iRDATA(I,JB) enddo ihfrpb(7)=iand(irptbl(2),mask34)/iscal2 IPRIOB = IHFRPB(7) IF(IPRIOB .LE. 0) GO TO 250 irptb(1)=iand(irptbl(1),mask12)/iscal4 irptb(2)=iand(irptbl(1),mask22) BSTNI = FRPTB(1) BSTNJ = FRPTB(2) C C ... PERFORM BOX TEST ... C IF(AILEF .GT. BSTNI) GO TO 250 IF(AIRIT .LT. BSTNI) GO TO 260 IF(AJLO .GT. BSTNJ) GO TO 250 IF(AJHI .LT. BSTNJ) GO TO 250 C C ... OTHERWISE, THIS STN B IS W/I BOX ... C ... SO THIS MAY BE AN INSIDER ... C DI = BSTNI - ASTNI DJ = BSTNJ - ASTNJ DISTSQ = DI*DI + DJ*DJ IF(DISTSQ .GT. CLOSSQ) GO TO 250 C C ... FOUND AN 'INSIDER' STN B ... C IF(NPASS .EQ. 2) GO TO 280 C C ... WHICH MEANS FOR NPASS 2 THAT WE CANNOT RESTORE STN A C ... BECAUSE THERE IS ANOTHER STN NEARBY ... C IF(IPRIOA - IPRIOB) 240,225,230 225 CONTINUE C C ... COMES HERE IF BOTH A AND B HAVE SAME PRIORITY, C ... IN WHICH CASE WE WILL KEEP BOTH, UNLESS THEY FALL VERY C ... CLOSE TO EACH OTHER LIKE A DUPLICATE REPORT C IF(DISTSQ .GT. VERYSQ) GO TO 250 C C ... OTHERWISE, DUPLICATE REPORT, SO TOSS STN B ... C LCODE = LD GO TO 231 230 CONTINUE C C ... COMES HERE TO PRINT A REMARK ABOUT TOSSING STN B C LCODE = LB 231 CONTINUE IPRIOB = -IABS(IPRIOB) IHFRPB(7) = IPRIOB c iRDATA(2,JB) = iRPTBl(2) irdata(2,jb) = ior(iand(irdata(2,jb),nask34), 1 iand(ihfrpb(7)*iscal2,mask34)) IPRNTA = IPRNTA + 1 IF(IPRNTA .GT. MXPRTA) GO TO 236 ihfrpb(8)=iand(irptbl(2),mask44) irptb(3)=iand(irptbl(2),mask12)/iscal4 irptec=irpta(3) PRINT 234, LCODE, crptei(5:8),IHFRPB(8), * IHFRPB(7),BSTNI,BSTNJ 234 FORMAT(10X, 'IN S/R TOSOUT MARKED FOR ', * 'TOSSOUT STN-', A1, 1 ' = ', A4, 3X, 'WITH OBSERVED QUANTITY = ', I6, 3X, 2 /, 20X, 'PRIORITY = ', I3, 3X, 'AT GRIDI = ', F9.3, 3X, 3 'GRIDJ = ', F9.3) 236 CONTINUE C C ... THEN GO GET ANOTHER B ... C GO TO 250 240 CONTINUE C C ... COMES HERE TO PRINT A REMARK ABOUT TOSSING STN A C LCODE = LA IPRIOA = -IABS(IPRIOA) IHFRPA(7) = IPRIOA irptal(2) = ior(iand(irptal(2),nask34), 1 iand(ihfrpa(7)*iscal2,mask34)) iRDATA(2,JA) = iRPTAl(2) IPRNTA = IPRNTA + 1 IF(IPRNTA .GT. MXPRTA) GO TO 245 ihfrpa(8)=iand(irptal(2),mask44) irpta(3)=iand(irptal(2),mask12)/iscal4 irptec=irpta(3) PRINT 234, LCODE,crptei(5:8),IHFRPA(8),IHFRPA(7), * ASTNI,ASTNJ 245 CONTINUE C C ... THEN GO GET ANOTHER STN A ... C GO TO 280 250 CONTINUE JB = JB + 1 255 CONTINUE C C ... WHEN IT FALLS THRU 255, ALL B PTS IN THIS STRIP HAVE C ... BEEN EXAMINED ... C 260 CONTINUE C C ... WHEN IT FALLS THRU 260, ALL STRIPS WITHIN RANGE OF PT A HAVE C ... BEEN EXAMINED ... C 264 CONTINUE IF(NPASS .NE. 2) GO TO 269 C C ... OTHERWISE, THIS IS 2ND PASS AND THIS STN A HAD NO C ... 'INSIDER' AT ALL, SO TURN ON THE PRIORITY OF STN A C ... WHICH HAD BEEN PREVIOUSLY BEEN SET TO 'TOSSED' C IHFRPA(7) = IPRIOA c iRDATA(2,JA) = iRPTAl(2) irdata(2,ja) = ior(iand(irdata(2,ja),nask34), 1 iand(ihfrpa(7)*iscal2,mask34)) IPRNTB = IPRNTB + 1 IF(IPRNTB .GT. MXPRTB) GO TO 269 ihfrpa(8)=iand(irptal(2),mask44) irpta(3)=iand(irptal(2),mask12)/iscal4 irptec=irpta(3) PRINT 266, cRPTei(5:8),IHFRPA(8),IHFRPA(7),ASTNI,ASTNJ 266 FORMAT(10X, 'IN S/R TOSOUT, 2ND PASS, RESTORED THE ', * 'FOLLOWING STN TO NOT-TOSSED STATUS: CALL LTRS = ', A4, * 3X, 'OBSVD QUANT = ', 2 I6, /, 20X, 'PRIORITY = ', I3, 3X, 'AT GRIDI = ', F9.3, 3 3X, 'GRIDJ = ', F9.3) 269 CONTINUE 280 CONTINUE 299 CONTINUE RETURN END c********************************************************************* SUBROUTINE TRUIJX(ALAT,ALONG,XI,XJ,KEIL,IRET_TIJ) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: TRUIJX COMPUTE I/J GRID COORDS FROM LAT/LONG C PRGMMR: SHIMOMURA ORG: W/NP12 DATE: 96-09-23 C C ABSTRACT: CONVERT A LOCATION FROM GIVEN LAT/LONG COORDINATES C TO GRID I/J COORDINATES. C C PROGRAM HISTORY LOG: C YY-MM-DD ORIGINAL AUTHOR(S)'S NAME(S) HERE C 91-10-25 LILLY ADDED DOCBLOCK C 96-09-23 SHIMOMURA: CONVERTED 91-10-23 VERSION TO CRAY C SINCE I ADDED RETURN CODE TO CALL SEQUENCE, C I CHANGED THE NAME OF THIS VERSION TO "TRUIJX" c 98-05-28 chris caruso removed cdir$ integer=64 from top c of this s/r for f90. C C USAGE: CALL TRUIJX(ALAT, ALONG, XI, XJ, KEIL, IRET_TIJ) C INPUT ARGUMENT LIST: C ALAT - REAL LATITUDE IN DEGREES NORTH C ALONG - REAL LONGITUDE IN DEGREES WEST (HOW IS EAST PUT?) C KEIL - INT CODE FOR THE GRID BEING USED C C OUTPUT ARGUMENT LIST: C XI - REAL GRID I-COORDINATE C XJ - REAL GRID J-COORDINATE C IRET_TIJ - RETURN CODE C = 0; NORMAL RETURN C =170; GIVEN ARG:KEIL IS OUT OF RANGE C C OUTPUT FILES: C FT06F001 - INCLUDE IF ANY PRINTOUT C C REMARKS: C CAUTION: 96-09-23/DSS -- I CHANGED CALL SEQUENCE TO ADD A RETURN C CODE, SINCE THE OLD VERSION HAD A STOP. C C CAUTION: 96-09-23/DSS -- I HAND-COPIED MODS FROM A VERSION FOUND C IN PLOT250V PACKAGE. C C ATTRIBUTES: C LANGUAGE: FORTRAN 90 C MACHINE: CRAY C C$$$ C ...TO COMPUTE I/J FROM GIVEN LAT/LONG... C ... ON THE GRID SPECIFIED BY KEIL... C C ...KEIL=1 FOR LFM GRID C ...KEIL=2 FOR STD NMC GRID C ...KEIL=3 FOR SRN HEMI 381KM GRID INT., 80W IS VERT. AT TOP, C SRN HEMI LATS HAVE NEG. VALUES C ...KEIL=4 (USED FOR PEATMOS POP) 190.5 KM GRID LENGTH, C ...KEIL=5 FOR SFC US 1/10M ADDED 23 FEB 73 C ...KEIL=6 FOR LARGER AREA SFC US 1/10M ADDED 12 JUNE 75 ... C ...KEIL=7 FOR LARGE NH 1/20M 105W FRONT 2/3 20 OCT 1975 ... C ...KEIL=8 FOR LARGE NH 1/20M BACK PANEL SIDEWAYS 20 OCT 75 ... C ...KEIL=9 FOR 65*65 N.HEMI 1/40M W/ 105W VERTICAL ... JAN 16, 76 C ...KEIL=10 FOR 47*51 N.HEMI 1/40M W/ 105W VERTICAL ... JAN 16, 76 C ...KEIL=11 FOR 51*51 LFM SUBSET OF 1/40M W/ 105W VERTICAL 1/16/76 C ...KEIL=12 FOR 53*57 FULL LFM GRID W/ 105W VERTICAL 7/22/76 C ...KEIL=13 FOR 43*31 LFM SUBSET W/ 105W VERT 7/23/76 C ...KEIL=14 FOR 65*65 STD NMC GRID NHEMI W/80W VERT 7/7/77 C ...KEIL=15 FOR 55*42 NA AFOS W/105W VERTICAL MAR 16,1981 C ...KEIL=16 FOR LARGE SH 1/20M W/ 60W VERTICAL APR 30, 1981 C ...KEIL=17 FOR 87*71 NH 1/20M W/105W VERTICAL JUN 9, 1982 C ...KEIL=18 FOR 48*44 NH 1/20M W/102.5W VERT (DLY WEA MAP) 9/26/82 C ...RE ASSUMES 6371.2 KM EARTH RADIUS ... INTEGER MXKEIL PARAMETER (MXKEIL=18) C ...WHERE KEIL IS MAX NO. OF GRIDS THIS S/R WORKS FOR REAL XIP(MXKEIL) REAL XJP(MXKEIL) REAL RE(MXKEIL) REAL ADDLNG(MXKEIL) C ... KEIL =1 =2 =3 =4 C ... LFM STD NMC SRN PEATMOS DATA XIP / 24.0, 24.0, 24.0, 24.0, X -35.0,-11.0,55.0,-15.0, Y 33.0, 24.0,26.0, 27.0, 17.0, Z 33.0, 27.0, 55.0, 40.0, 21.0 / DATA XJP / 46.0, 26.0, 26.0, 46.0, X 2*47.0, 51.0, 55.0, Y 33.0, 26.0,46.0, 49.0, 46.0, Z 33.0, 46.0, 65.0, 73.0, 48.0 / DATA RE / 62.40866, 31.20433, 31.20433, 62.40866, X 2*124.81733, 2*62.40866, Y 2*31.20433, 3*62.40866, 31.20433, 2*62.40866, Z 93.61299, 62.40866 / DATA ADDLNG / 75.0, 100.0, 80.0, 82.0, X -15.0,-15.0,75.0,165.0, Y 5*75.0, Z 100.0, 75.0, 60.0, 75.0, 77.5 / C ... VERT MERIDIAN... 105W 80W 100E 98W ... C ...KEIL=5 AND =6 HAVE VERT MERIDIAN AT 195 W ... C ...KEIL=7 VERT MERID IS 105W, KEIL=8 VERT MERID IS 15W ... C ...KEIL=9,10,11,12,13 HAVE VERT MERIDIAN AT 105W C ...KEIL=14 80W VERT C ...KEIL=15 105W VERTICAL C ...KEIL=16 60W VERTICAL C ...KEIL=17 105W VERTICAL C ...KEIL=18 102.5W VERT REAL CONVT DATA CONVT /1.745329E-02/ C . . . . . . . . . . . REAL ALAT REAL ALONG REAL XI REAL XJ INTEGER KEIL INTEGER IRET_TIJ C . . . . . . . . . . . REAL XLAT REAL WLONG SAVE C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . IRET_TIJ = 0 XI = 0.0 XJ = 0.0 KEY = KEIL IF((KEY .LE. 0) .OR. (KEY .GT. MXKEIL)) THEN C ...COMES HERE IF GIVEN KEIL WAS OUT OF ALLOWABLE RANGE WRITE(6,FMT='(1H ,/1H ,''TRUIJX: ERROR. ARGUMENT "KEIL"'', 1 '' OUT-OF-RANGE. KEIL= HEX '', Z8.8)') A KEIL IRET_TIJ = 170 GO TO 999 ENDIF C ...OTHERWISE, KEIL IS W/I RANGE IF((KEY .EQ. 3) .OR. (KEY .EQ. 16)) THEN C ...FALLS THRU TO HERE FOR SRN HEMI ONLY... XLAT = -ALAT * CONVT WLONG = 360.0 - ALONG WLONG = (WLONG + ADDLNG(KEY)) * CONVT ELSE XLAT = ALAT * CONVT WLONG = (ALONG + ADDLNG(KEY)) * CONVT ENDIF R = (RE(KEY) * COS(XLAT)) / (1.0 + SIN(XLAT)) XI = XIP(KEY) + R*SIN(WLONG) XJ = XJP(KEY) + R*COS(WLONG) GO TO 999 999 CONTINUE RETURN END c********************************************************************* SUBROUTINE WRTAFS(IHD3,AFSFIL,IRETN) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: WRTAFS FORMATS AND WRITES AN AFOS PRODUCT. C PRGMMR: LUKE LIN ORG: W/NMC412 DATE: 95-01-04 C C ABSTRACT: WRITES AN AFOS PRODUCT TO THE OUTPUT FILE. C C PROGRAM HISTORY LOG: C 94-06-29 ORIGINAL AUTHOR LUKE LIN C 95-01-04 LUKE LIN CONVERT IT CFT-77. C 95-01-06 LUKE LIN REPLACE FFPUT BY UNBLOCKED WRITE. c 98-06-19 chris caruso - extend common ispaceaf to equal length c of that common in s/r iniafbin c 99-08-09 chris caruso - change writes to afos output file to c direct access. C C USAGE: CALL WRTAFS(IHD3,AFSFIL,IRETN) C INPUT ARGUMENT LIST: C IHD3 - CHARACTER*23 ARRAY THAT CONTAINS THE AFOS PRODUCT C - COMMUNICATIONS HEADER. C AFSFIL - AFOS OUTPUT FILE UNIT NUMBER 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 OUTPUT ARGUMENT LIST: C IRETN - =0, NORMAL C =1, EXCEED MAXIMUM AFOS BLOCKS C C C OUTPUT FILES: C FT06F001 - PRINT FILE. C FTXXF001 - FILE THAT CONTAINS THE COMPLETED AFOS MAPS C - WHERE XX = AFSFIL. 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 common/reccnt/ nrecnaf integer nrecnaf logical lod character*8 cdir C CHARACTER*1280 KBLOCK INTEGER KBLOCK8(160) EQUIVALENCE (KBLOCK,KBLOCK8(1)) C CHARACTER*23 IHD3 C CHARACTER*7 TSTPAT INTEGER ITSTPAT EQUIVALENCE (TSTPAT,ITSTPAT) C CHARACTER*4 IBEG INTEGER IIBEG EQUIVALENCE (IBEG,IIBEG) C CHARACTER*2 DLEFF INTEGER IDLEFF EQUIVALENCE (DLEFF,IDLEFF) CHARACTER*2 DLEDLE INTEGER IDLEDLE EQUIVALENCE (DLEDLE,IDLEDLE) C CHARACTER*1 DLE CHARACTER*1 ETX CHARACTER*1 FSTLST CHARACTER*1 ILAST C INTEGER IOVFLOW(7) CHARACTER*1 OVFLOW(49) EQUIVALENCE (IOVFLOW(1),OVFLOW(1)) C CHARACTER*1 PAD CHARACTER*1 ZERO C INTEGER AFSBLK INTEGER AFSFIL INTEGER MAXBYT INTEGER NUMBIG INTEGER NUMBYT C C NUMBYT IS BYTE COUNTER THAT RANGES FROM 1 TO 256 WHICH IS THE C MAX NUMBER OF BYTES IN AN AFOS UGF RECORD. C LOGICAL MAXBLK C DATA IDLEDLE / Z'1010000000000000' / DATA IDLEFF / Z'100C000000000000' / DATA IIBEG / Z'0100000000000000' / DATA ITSTPAT / Z'C500003205CE3700' / DATA IOVFLOW /Z'C500003205004441',Z'5441204F56455246', 1 Z'4C4F57202D544849',Z'53204D4150204D41', 2 Z'59204E4F54204245',Z'20434F4D504C4554', 3 Z'4500000000000000'/ DATA MAXBYT /256/ C save c c verify that afsfil was opened as direct access. c inquire(unit=afsfil,opened=lod,direct=cdir) if(lod) then print*,' afsfil opened as direct access' endif ZERO = CHAR(00) PAD = CHAR(255) DLE = CHAR(16) ETX = CHAR(131) FSTLST = CHAR(192) ILAST = CHAR(128) C C CHECK TO SEE IF LBNKFG IS -1 IF .TURE. THE SUBTRACT ONE FROM C ICNTOT AND RESET LBNKFG TO 0. C IF(LBNKFG.EQ.-1)THEN ICNTOT = ICNTOT - 1 LBNKFG = 0 WRITE(6,FMT='('' WRTAFS: BLANK FILLER FLAG WAS ON.'')') ENDIF C IRETN = 0 NOBLOK = 0 MAXBLK = .FALSE. WRITE(6,FMT='('' WRTAFS: AFOS PRODUCT HAS'',I6, 1 '' BYTES.'')')ICNTOT C IF(ICNTOT.GT.14848) THEN WRITE(6,FMT='('' WRTAFS: THIS AFOS PRODUCT HAS'',I6, 1 '' BYTES. WHICH EXCEEDS 64 BLOCKS.'')')ICNTOT C ICNTOT = 14848 MAXBLK = .TRUE. IRETN = 1 ENDIF C JCNTOT = 1 NUMBIG = 0 WRITE(6,FMT='('' WRTAFS: WRITING AFOS MAP TO FT'',I2, 1 ''F001'')')AFSFIL C AFSBLK = 1 C KBLOCK(1:23) = IHD3(1:23) C NUMBYT = 24 JCNTOT = 24 DO LOOP = 1,ICNTOT C C ...TEST FOR DATA OVERFLOW C IF(.NOT.(MAXBLK)) GO TO 110 C IF(LOOP.EQ.13) THEN C C ...PUT OVERFLOW MSG ON MAP C DO I3 = 1,49 IF(NUMBYT.EQ.(MAXBYT+1)) THEN IF(AFSBLK.EQ.5) THEN C C ...OTHERWISE 1280 BYTE COMMS RECORD IS FULL AND MUST BE OUTPUT C NUMBIG = NUMBIG + 1 AFSBLK = 0 JCNTOT = 1 c WRITE(AFSFIL)KBLOCK8 nrecnaf = nrecnaf + 1 write(afsfil,rec=nrecnaf) kblock8 C NOBLOK = NOBLOK + 1 ENDIF AFSBLK = AFSBLK + 1 NUMBYT = 1 C C LOAD BEGINNING OF RECORD FLAG. C KBLOCK(JCNTOT:JCNTOT+3) = IBEG(1:4) JCNTOT = JCNTOT + 4 C NUMBYT = 5 ENDIF C KBLOCK(JCNTOT:JCNTOT) = OVFLOW(I3) JCNTOT = JCNTOT + 1 NUMBYT = NUMBYT + 1 enddo ENDIF C 110 CONTINUE IF(NUMBYT.EQ.(MAXBYT+1)) THEN IF(AFSBLK.EQ.5) THEN C C ... OTHERWISE 1280 BYTE COMMS RECORD IS FULL AND MUST BE OUTPUT C NUMBIG = NUMBIG + 1 AFSBLK = 0 JCNTOT = 1 c WRITE(AFSFIL)KBLOCK8 nrecnaf = nrecnaf + 1 write(afsfil,rec=nrecnaf) kblock8 NOBLOK = NOBLOK + 1 ENDIF AFSBLK = AFSBLK + 1 NUMBYT = 1 C C LOAD BEGINNING OF RECORD FLAG. C KBLOCK(JCNTOT:JCNTOT+3) = IBEG(1:4) JCNTOT = JCNTOT + 4 NUMBYT = 5 ENDIF C 120 CONTINUE IF(LBLOCK(LOOP).EQ.ETX) THEN KBLOCK(JCNTOT:JCNTOT) = DLEFF(1:1) JCNTOT = JCNTOT + 1 NUMBYT = NUMBYT + 1 IF(NUMBYT.EQ.(MAXBYT+1)) THEN IF(AFSBLK.EQ.5) THEN C C THE 1280 BYTE COMMS RECORD IS FULL AND MUST BE OUTPUT C NUMBIG = NUMBIG + 1 AFSBLK = 0 JCNTOT = 1 c WRITE(AFSFIL)KBLOCK8 nrecnaf = nrecnaf + 1 write(afsfil,rec=nrecnaf) kblock8 NOBLOK = NOBLOK + 1 ENDIF AFSBLK = AFSBLK + 1 NUMBYT = 1 C C LOAD BEGINNING OF RECORD FLAG. C KBLOCK(JCNTOT:JCNTOT+3) = IBEG(1:4) JCNTOT = JCNTOT + 4 NUMBYT = 5 ENDIF C KBLOCK(JCNTOT:JCNTOT) = DLEFF(2:2) JCNTOT = JCNTOT + 1 NUMBYT = NUMBYT + 1 C ELSEIF(LBLOCK(LOOP).EQ.DLE) THEN KBLOCK(JCNTOT:JCNTOT) = DLEDLE(1:1) JCNTOT = JCNTOT + 1 NUMBYT = NUMBYT + 1 IF(NUMBYT.EQ.(MAXBYT+1)) THEN IF(AFSBLK.EQ.5) THEN C C ... OTHERWISE 1280 BYTE COMMS RECORD IS FULL AND MUST BE OUTPUT C NUMBIG = NUMBIG + 1 AFSBLK = 0 JCNTOT = 1 C c WRITE(AFSFIL)KBLOCK8 nrecnaf = nrecnaf + 1 write(afsfil,rec=nrecnaf) kblock8 NOBLOK = NOBLOK + 1 ENDIF AFSBLK = AFSBLK + 1 NUMBYT = 1 C C LOAD BEGINNING OF RECORD FLAG. C KBLOCK(JCNTOT:JCNTOT+3) = IBEG(1:4) JCNTOT = JCNTOT + 4 NUMBYT = 5 ENDIF C KBLOCK(JCNTOT:JCNTOT) = DLEDLE(2:2) JCNTOT = JCNTOT + 1 NUMBYT = NUMBYT + 1 C ELSE KBLOCK(JCNTOT:JCNTOT) = LBLOCK(LOOP) JCNTOT = JCNTOT + 1 NUMBYT = NUMBYT + 1 ENDIF enddo C C ...NOW ADD FORMAT VERSION INDICATOR IN UPPER LEFT OF MAP C ...SKIP IF DATA OVERFLOW C IF(.NOT. MAXBLK) THEN DO I3 = 1,7 IF(NUMBYT.EQ.(MAXBYT+1)) THEN IF(AFSBLK.EQ.5) THEN C C OUTPUT A 1280 BYTE RECORD BECAUSE IT IS FULL. C NUMBIG=NUMBIG+1 AFSBLK=0 JCNTOT=1 c WRITE(AFSFIL)KBLOCK8 nrecnaf = nrecnaf + 1 write(afsfil,rec=nrecnaf) kblock8 NOBLOK = NOBLOK + 1 ENDIF AFSBLK=AFSBLK+1 NUMBYT=1 C C LOAD BEGINNING OF RECORD FLAG. C KBLOCK(JCNTOT:JCNTOT+3)=IBEG(1:4) JCNTOT=JCNTOT+4 NUMBYT=5 ENDIF C KBLOCK(JCNTOT:JCNTOT)=TSTPAT(I3:I3) JCNTOT=JCNTOT+1 NUMBYT=NUMBYT+1 ENDDO ENDIF IF(NUMBYT.EQ.(MAXBYT+1)) THEN C C THIS BLOCK IS EXACTLY FULL, SO PUT ETX IN NEXT BLOCK C IF(AFSBLK.EQ.5) THEN NUMBIG=NUMBIG+1 AFSBLK=0 JCNTOT=1 NOBLOK = NOBLOK + 1 c WRITE(AFSFIL)KBLOCK8 nrecnaf = nrecnaf + 1 write(afsfil,rec=nrecnaf) kblock8 ENDIF AFSBLK=AFSBLK+1 C C LOAD BEGINNING OF RECORD FLAG. C KBLOCK(JCNTOT:JCNTOT+3)=IBEG(1:4) JCNTOT=JCNTOT+4 NUMBYT=5 ENDIF JCNTOT=JCNTOT-(NUMBYT-3) KBLOCK(JCNTOT:JCNTOT)=ILAST JCNTOT=JCNTOT+(NUMBYT-3) KBLOCK(JCNTOT:JCNTOT)=ETX JCNTOT=JCNTOT+1 IF(MOD(JCNTOT,2).EQ.0) THEN KBLOCK(JCNTOT:JCNTOT)=PAD JCNTOT=JCNTOT+1 ENDIF C C CHECK TO SEE IF WE ARE STILL WORKING ON THE 1ST 1280 C BYTE BUFFER. C IF(NUMBIG.EQ.0)THEN C C WORKING ON 1ST 1280 BYTE BUFFER SO, C CHECK TO SEE IF WE ARE STILL WORKING ON THE 1ST 256 C BYTE RECORD IN THIS 1280 BYTE BUFFER. C IF(AFSBLK.EQ.1)THEN C C LOAD FIRST AND LAST FLAG INTO THE 3RD BYTE OF KBLOCK. C KBLOCK(3:3)=FSTLST(1:1) ENDIF ENDIF C C FILL REST OF KBLOCK WITH ZERO. C DO JJ = JCNTOT,1280 KBLOCK(JJ:JJ) = ZERO ENDDO C NOBLOK = NOBLOK + 1 WRITE(6,FMT='('' WRTAFS: NUMBER OF BLOCKS='',I4)')NOBLOK C c WRITE(AFSFIL)KBLOCK8 nrecnaf = nrecnaf + 1 write(afsfil,rec=nrecnaf) kblock8 C IRECD = 5 * NUMBIG + AFSBLK C WRITE(6,FMT='('' WRTAFS: THIS MAP HAS'',I3,'' RECORDS.'')') 1 IRECD C RETURN END c********************************************************************* SUBROUTINE WXDSEC(NOBS,FIJDAT,JTM,nstntb,ikfax,ikafos) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: WXDSEC COUNT OBS IN THE GIVEN FIJDAT ARRAY C PRGMMR: WOBUS ORG: W/NP20 DATE: 97-01-24 C C ABSTRACT: TO COUNT OBS IN THE GIVEN FIJDAT ARRAY BY SECTIONS OF THE C COUNTRY; TO DETECT THOSE SECTORS WHERE MISSING DATA WILL RESULT IN C BAD ANALYSIS C C PROGRAM HISTORY LOG: C 80-04-01 DAVE SHIMOMURA C 94-01-04 LUKE LIN CONVERT IT FORTRAN 77 AND ADD DOC BLOCK. C 97-01-24 RICHARD WOBUS - CONVERT TO CRAY, ADD STN COUNT c 98-05-28 chris caruso removed cdir$ integer=64 from top c of this s/r for f90. C C USAGE: CALL WXDSEC(NOBS,FIJDAT,JTM) C INPUT ARGUMENT LIST: C NOBS - NO OF OBS IN FIJDAT ARRAY C FIJDAT - ARRAY OF OBS DATA. C JTM - J-DIMENSION OF FIJDAT C C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) C ERRFLAG - EVEN IF MANY LINES ARE NEEDED C C ATTRIBUTES: C LANGUAGE: cray fortran 90 C MACHINE: CRAY4 C C$$$ COMMON/KPLOT/LABEL(2,1024),LABIX,NOBUF,IDRA(50) COMMON/PUTARG/PUTHGT,PUTANG,IPRPUT,ITAPUT real FIJDAT(3,JTM) CHARACTER*12 KREM1 CHARACTER*12 KREM2 CHARACTER*12 KREM3 CHARACTER*12 KREM4 CHARACTER*16 JREM1 CHARACTER*16 JREM2 CHARACTER*16 JREM1A CHARACTER*16 JREM1B CHARACTER*4 IFOR02 data IFOR02/'A999'/ CHARACTER*4 IFORM integer krot_pri(2) DIMENSION IINW(4) DIMENSION IISW(4) DIMENSION IIWC(4) DIMENSION IINC(4) DIMENSION IISC(4) DIMENSION IICC(4) DIMENSION IINE(4) DIMENSION IISE(4) DIMENSION IIEC(4) CHARACTER*4 INTG2(2) DATA KREM1/ ' ANALYSIS '/ DATA KREM2/ 'UNRELIABLE '/ DATA KREM3/ ' DUE TO '/ DATA KREM4/ ' DATA LOSS '/ DATA JREM1/ 'TOTAL STATIONS '/ DATA JREM2/ ' OUT OF '/ DATA JREM1A/ ' AVAILABLE FOR '/ DATA JREM1B/ ' ANALYSIS '/ DATA JJNTOT/280/ DATA IIWC/ 64, 32, 8,22/ DATA IICC/ 28, 15,17,22/ DATA IIEC/ 77, 50,26,22/ DATA IINW/139, 70, 8,16/ DATA IINC/214,120,17,16/ DATA IINE/307,160,26,16/ DATA IISW/108, 55, 8, 9/ DATA IISC/142, 80,17, 9/ DATA IISE/143, 80,26, 9/ c DATA GRIA,GRIB,GRIC,GRID/5.0,15.0,23.0,34.0/ DATA GRJA,GRJB,GRJC,GRJD/2.0,12.0,19.0,23.0/ save iintot = nstntb c c initialize for afos print c ib = 0 irb = 0 izt = 0 isize = 0 ianum = 11 iaden = 16 ijoff = 270 ikoff = 385 janum = 11 jaden = 16 jjoff = 160 jkoff = 160 C C INITIALIZE SECTION COUNTERS C INW = 0 ISW = 0 INC = 0 ISC = 0 INE = 0 ISE = 0 IWC = 0 ICC = 0 IEC = 0 IEMPT = 0 C DO 69 JS = 1, NOBS c C ESTABLISH SECTION COUNTERS C XI = FIJDAT(1,JS) RELIFM = XI - 1.0 RELIG = RELIFM/2.0 GRIDII = RELIG + 1.0 XJ = FIJDAT(2,JS) RELJFM = XJ - 1.0 RELJG = RELJFM/2.0 GRIDJJ = RELJG + 1.0 IF(GRIDII.GT.GRIA.AND.GRIDII.LE.GRIB) GO TO 60 IF(GRIDII.GT.GRIB .AND.GRIDII.LE.GRIC) GO TO 61 IF(GRIDII.GT.GRIC .AND.GRIDII.LE.GRID) GO TO 62 IEMPT = IEMPT + 1 GO TO 69 C C NORTHWEST US/SOUTHWEST US/WESTERN CANADA C 60 CONTINUE IF(GRIDJJ.GT.GRJA.AND.GRIDJJ.LE.GRJB) GO TO 63 IF(GRIDJJ.GT.GRJB .AND.GRIDJJ.LE.GRJC) GO TO 64 IF(GRIDJJ.GT.GRJC .AND.GRIDJJ.LE.GRJD) GO TO 641 IEMPT = IEMPT + 1 GO TO 69 63 CONTINUE ISW = ISW + 1 GO TO 69 64 CONTINUE INW = INW + 1 GO TO 69 641 CONTINUE IWC = IWC + 1 GO TO 69 C C NORTH CENTRAL US/SOUTH CENTRAL US/CENTRAL CANADA C 61 CONTINUE IF(GRIDJJ.GT.GRJA.AND.GRIDJJ.LE.GRJB) GO TO 65 IF(GRIDJJ.GT.GRJB .AND.GRIDJJ.LE.GRJC) GO TO 66 IF(GRIDJJ.GT.GRJC .AND.GRIDJJ.LE.GRJD) GO TO 661 IEMPT = IEMPT + 1 GO TO 69 65 CONTINUE ISC = ISC + 1 GO TO 69 66 CONTINUE INC = INC + 1 GO TO 69 661 CONTINUE ICC = ICC + 1 GO TO 69 C C NORTHEAST US/SOUTHEAST US/EASTERN CANADA C 62 CONTINUE IF(GRIDJJ.GT.GRJA.AND.GRIDJJ.LE.GRJB) GO TO 67 IF(GRIDJJ.GT.GRJB .AND.GRIDJJ.LE.GRJC) GO TO 68 IF(GRIDJJ.GT.GRJC .AND.GRIDJJ.LE.GRJD) GO TO 681 IEMPT = IEMPT + 1 GO TO 69 67 CONTINUE ISE = ISE + 1 GO TO 69 68 CONTINUE INE = INE + 1 GO TO 69 681 CONTINUE IEC = IEC + 1 69 CONTINUE INTOT = INW + ISW + IWC INTOT = INTOT + INC + ISC + ICC INTOT = INTOT + INE + ISE + IEC C PRINT 96,INW,ISW,IWC 96 FORMAT(' WEST SECTION COUNTERS-INW= ',I4, X ' ISW= ',I4,' IWC= ',I4) C PRINT 97,INC,ISC,ICC 97 FORMAT(' CENTRAL SECTION COUNTERS-INC= ',I4, X ' ISC= ',I4,' ICC= ',I4) C PRINT 98,INE,ISE,IEC 98 FORMAT(' EAST SECTION COUNTERS-INE= ',I4, X ' ISE= ',I4,' IEC= ',I4) C PRINT 100,INTOT,IEMPT 100 FORMAT(' TOTAL COUNTERS-INTOT= ',I4,' IEMPT= ',I4) C C OUTPUT ERROR MESSAGES ON MAP C IITST = IINW(1) JJTST = IINW(2) PRINT 111,INW,IITST 111 FORMAT(' TOTAL STATIONS FOUND-NORTHWEST SECTION =',I4, X ' OUT OF ',I4,' STATIONS ') IF(INW.LE.JJTST) GO TO 131 121 CONTINUE IITST = IISW(1) JJTST = IISW(2) PRINT 112,ISW,IITST 112 FORMAT(' TOTAL STATIONS FOUND-SOUTHWEST SECTION =',I4, X ' OUT OF ',I4,' STATIONS ') IF(ISW.LE.JJTST) GO TO 132 122 CONTINUE IITST = IINC(1) JJTST = IINC(2) PRINT 113,INC,IITST 113 FORMAT(' TOTAL STATIONS FOUND-NORTH CENTRAL SECTION =',I4, X ' OUT OF ',I4,' STATIONS ') IF(INC.LE.JJTST) GO TO 133 123 CONTINUE IITST = IISC(1) JJTST = IISC(2) PRINT 114,ISC,IITST 114 FORMAT(' TOTAL STATIONS FOUND-SOUTH CENTRAL SECTION =',I4, X ' OUT OF ',I4,' STATIONS ') IF(ISC.LE.JJTST) GO TO 134 124 CONTINUE IITST = IINE(1) JJTST = IINE(2) PRINT 115,INE,IITST 115 FORMAT(' TOTAL STATIONS FOUND-NORTHEAST SECTION =',I4, X ' OUT OF ',I4,' STATIONS ') IF(INE.LE.JJTST) GO TO 135 125 CONTINUE IITST = IISE(1) JJTST = IISE(2) PRINT 116,ISE,IITST 116 FORMAT(' TOTAL STATIONS FOUND-SOUTHEAST SECTION =',I4, X ' OUT OF ',I4,' STATIONS ') IF(ISE.LE.JJTST) GO TO 136 126 CONTINUE IITST = IIWC(1) JJTST = IIWC(2) PRINT 118,IWC,IITST 118 FORMAT(' TOTAL STATIONS FOUND-WESTERN CANADA SECTION=',I4, X ' OUT OF ',I4,' STATIONS ') IF(IWC.LE.JJTST) GO TO 138 127 CONTINUE IITST = IICC(1) JJTST = IICC(2) PRINT 119,ICC,IITST 119 FORMAT(' TOTAL STATIONS FOUND-CENTRAL CANADA SECTION=',I4, X ' OUT OF ',I4,' STATIONS ') IF(ICC.LE.JJTST) GO TO 1381 128 CONTINUE IITST = IIEC(1) JJTST = IIEC(2) PRINT 120,IEC,IITST 120 FORMAT(' TOTAL STATIONS FOUND-EASTERN CANADA SECTION=',I4, X ' OUT OF ',I4,' STATIONS ') IF(IEC.LE.JJTST) GO TO 140 129 CONTINUE IITST = IINTOT JJTST = JJNTOT PRINT 117,INTOT,IITST 117 FORMAT(' TOTAL STATIONS FOUND-WHOLE MAP =',I4, X ' OUT OF ',I4,' STATIONS ') PRINT 148,iwc,icc,iec,inw,inc,ine,isw,isc,ise,intot,iitst 148 FORMAT(' STATION TOTALS: ',11I5) NCHAR = 4 IFORM = IFOR02 INTG = INTOT write(JREM2(1:4),'(i4)') INTG INTG = IINTOT write(JREM2(13:16),'(i4)') INTG IXL = 225 JXL = 375 itaput = 0 HT = 1.0 NCHAR = 16 krot_pri(1) = 0 krot_pri(2) = 0 CALL PUTLAB(IXL,JXL,HT,JREM1,0.0,NCHAR,krot_pri,ITAPUT) ixa = (ixl*ianum)/iaden + ijoff jxa = (jxl*janum)/jaden + jjoff call afmdc5(jrem1,nchar,ixa,jxa,ib,irb,izt,isize,iretn) JXL = JXL - 30 itaput = 0 krot_pri(1) = 0 krot_pri(2) = 0 CALL PUTLAB(IXL,JXL,HT,JREM1A,0.0,NCHAR,krot_pri,ITAPUT) ixa = (ixl * ianum)/iaden + ijoff jxa = (jxl * janum)/jaden + jjoff call afmdc5(jrem1a,nchar,ixa,jxa,ib,irb,izt,isize,iretn) JXL = JXL - 30 itaput = 0 krot_pri(1) = 0 krot_pri(2) = 0 CALL PUTLAB(IXL,JXL,HT,JREM1B,0.0,NCHAR,krot_pri,ITAPUT) ixa = (ixl * ianum)/iaden + ijoff jxa = (jxl * janum)/jaden + jjoff call afmdc5(jrem1b,nchar,ixa,jxa,ib,irb,izt,isize,iretn) JXL = JXL - 30 itaput = 0 krot_pri(1) = 0 krot_pri(2) = 0 CALL PUTLAB(IXL,JXL,HT,JREM2,0.0,NCHAR,krot_pri,ITAPUT) ixa = (ixl * ianum)/iaden + ijoff jxa = (jxl * janum)/jaden + jjoff call afmdc5(jrem2,nchar,ixa,jxa,ib,irb,izt,isize,iretn) IF(INTOT.LE.JJTST) GO TO 137 GO TO 141 131 CONTINUE IXL = IINW(3) JXL = IINW(4) ISECT = 1 GO TO 139 132 CONTINUE IXL = IISW(3) JXL = IISW(4) ISECT = 2 GO TO 139 133 CONTINUE IXL = IINC(3) JXL = IINC(4) ISECT = 3 GO TO 139 134 CONTINUE IXL = IISC(3) JXL = IISC(4) ISECT = 4 GO TO 139 135 CONTINUE IXL = IINE(3) JXL = IINE(4) ISECT = 5 GO TO 139 136 CONTINUE IXL = IISE(3) JXL = IISE(4) ISECT = 6 GO TO 139 138 CONTINUE IXL = IIWC(3) JXL = IIWC(4) ISECT = 7 GO TO 139 1381 CONTINUE IXL = IICC(3) JXL = IICC(4) ISECT = 8 GO TO 139 140 CONTINUE IXL = IIEC(3) JXL = IIEC(4) ISECT = 9 GO TO 139 137 CONTINUE IXL = 200 JXL = 420 jxl = 500 HT = 1.0 NCHAR = 12 itaput = 0 krot_pri(1) = 0 krot_pri(2) = 0 CALL PUTLAB(IXL,JXL,HT,KREM1,0.0,NCHAR,krot_pri,ITAPUT) ixa = (ixl * ianum)/iaden + ijoff jxa = (jxl * janum)/jaden + jjoff call afmdc5(krem1,nchar,ixa,jxa,ib,irb,izt,isize,iretn) JXL = JXL - 30 itaput = 0 krot_pri(1) = 0 krot_pri(2) = 0 CALL PUTLAB(IXL,JXL,HT,KREM2,0.0,NCHAR,krot_pri,ITAPUT) ixa = (ixl * ianum)/iaden + ijoff jxa = (jxl * janum)/jaden + jjoff call afmdc5(krem2,nchar,ixa,jxa,ib,irb,izt,isize,iretn) JXL = JXL - 30 NCHAR = 12 itaput = 0 krot_pri(1) = 0 krot_pri(2) = 0 CALL PUTLAB(IXL,JXL,HT,KREM3,0.0,NCHAR,krot_pri,ITAPUT) ixa = (ixl * ianum)/iaden + ijoff jxa = (jxl * janum)/jaden + jjoff call afmdc5(krem3,nchar,ixa,jxa,ib,irb,izt,isize,iretn) JXL = JXL - 30 itaput = 0 krot_pri(1) = 0 krot_pri(2) = 0 CALL PUTLAB(IXL,JXL,HT,KREM4,0.0,NCHAR,krot_pri,ITAPUT) ixa = (ixl * ianum)/iaden + ijoff jxa = (jxl * janum)/jaden + jjoff call afmdc5(krem4,nchar,ixa,jxa,ib,irb,izt,isize,iretn) GO TO 141 139 CONTINUE HT = 1.0 NCHAR = 12 ZIXL = IXL ZIXL = ZIXL * 56.25 + 0.5 ZJXL = JXL ZJXL = ZJXL * 56.25 + 0.5 IIXL = ZIXL JJXL = ZJXL itaput = 0 krot_pri(1) = 0 krot_pri(2) = 0 CALL PUTLAB(IIXL,JJXL,HT,KREM1,0.0,NCHAR,krot_pri,ITAPUT) ixa = (iixl * ianum)/iaden + ikoff jxa = (jjxl * janum)/jaden + jkoff call afmdc5(krem1,nchar,ixa,jxa,ib,irb,izt,isize,iretn) itaput = 0 JJXL = JJXL - 35 krot_pri(1) = 0 krot_pri(2) = 0 CALL PUTLAB(IIXL,JJXL,HT,KREM2,0.0,NCHAR,krot_pri,ITAPUT) ixa = (iixl * ianum)/iaden + ikoff jxa = (jjxl * janum)/jaden + jkoff call afmdc5(krem2,nchar,ixa,jxa,ib,irb,izt,isize,iretn) itaput = 0 JJXL = JJXL - 35 NCHAR = 12 krot_pri(1) = 0 krot_pri(2) = 0 CALL PUTLAB(IIXL,JJXL,HT,KREM3,0.0,NCHAR,krot_pri,ITAPUT) ixa = (iixl * ianum)/iaden + ikoff jxa = (jjxl * janum)/jaden + jkoff call afmdc5(krem3,nchar,ixa,jxa,ib,irb,izt,isize,iretn) itaput = 0 JJXL = JJXL - 35 krot_pri(1) = 0 krot_pri(2) = 0 CALL PUTLAB(IIXL,JJXL,HT,KREM4,0.0,NCHAR,krot_pri,ITAPUT) ixa = (iixl * ianum)/iaden + ikoff jxa = (jjxl * janum)/jaden + jkoff call afmdc5(krem4,nchar,ixa,jxa,ib,irb,izt,isize,iretn) GO TO (121,122,123,124,125,126,127,128,129),ISECT 141 CONTINUE 999 CONTINUE RETURN END c********************************************************************** SUBROUTINE CNTRI(IRET_CNT, IMAGE, IMAGSIZ_WRDS,IWINDOW, 1 MAP, LABEL, INDEX,NFLDS, 2 FLD1, DASH1, OFSET1, SHAD1, 3 FLD2, DASH2, OFSET2, SHAD2, 4 FLD3, DASH3, OFSET3, SHAD3, 5 FLD4, DASH4, OFSET4, SHAD4) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: CNTRI CONTOUR THE INPUT FIELDS. C PRGMMR: CHRIS CARUSO ORG: NP12 DATE: 98-05-21 C C ABSTRACT: CONTOUR THE INPUT FIELDS. C C PROGRAM HISTORY LOG: C 96-04-08 ORIGINAL AUTHOR LUKE LIN C 96-04-19 LUKE LIN MODIFY FOR IMAGE AGRUMENTS. c 98-05-21 Chris Caruso remove unused variables and fix c a logic error inside loop where c ldouble is being set (if ldouble c is set to true in any loop iteration, c subsequent loop iterations can't c reset it to false if needed. add c additional then-else to if block c to fix this). C C USAGE: call cntri(iret_cnt,image,imagsiz_wrds,iwindow, c 1 MAP, LABEL, INDEX,NFLDS, c 2 FLD1, DASH1, OFSET1, SHAD1, c 3 FLD2, DASH2, OFSET2, SHAD2, c 4 FLD3, DASH3, OFSET3, SHAD3, c 5 FLD4, DASH4, OFSET4, SHAD4) C INPUT ARGUMENTS: c iwindow - map array converted to window array. C MAP - INTEGER*4 MAP(15) IS A LIST CONTAINING: C MAP(1): BACKGROUND NAME IN 6 CHARACTERS, FOLLOWED BY C TWO BYTES OF FILL -- NULL IS PREFERRED C C MAP(2): FLAGS IN TWO LOW-ORDER BYTES C X'0001' = HASH THE BGND (TURN OFF EVERY OTHER PIXEL); C X'0002' = DOUBLE THE SCALE OF THIS BGND; C X'0004' = 2-PANEL ... TO PLACE A DUPLICATE OF A CUT C OUT OF THE GIVEN MAP-BACKGROUND BESIDE C THE FIRST; C X'0008' = LEAVE PRODUCT OPEN AT END OF THIS CALL; C X'0010' = ADD THIS PRODUCT ONTO AN OPEN PRODUCT FILE; C X'0020' = CYCLIC PRODUCT; C (SOME SIDEWAYS MERCATOR PRODUCTS CAN C EXTEND BEYOND LAST SCANLINE BY CYCLING TO C CONTINUE WITH THE FIRST SCANLINE. IF THE C DESIRED PRODUCT AND ITS MERCATOR GRID C DOES NOT END AT THE SAME MERIDIAN AS THE C MAP BGND, THEN THIS OPTION WILL PERMIT C THE GEOGRAPHY TO EXTEND CYCLICALLY.) C X'0040' = AFOS OUTPUT REQUIRED. C C FOLLOWED BY THE MAP REGISTRATION CONSTANTS: C MAP(3), (4), (5), (6): (FOR THE ENTIRE PRODUCT), C I, J, WIDTH,LENGTH C MAP(7), (8), (9), (10): (FOR THE MAP BACKGROUND), C I, J, WIDTH,LENGTH C MAP(11),(12): FOR CONTOUR-POSITION FINE-ADJUSTMENT C DI, DJ C MAP(13),(14): FOR TEXT- & SYMBOL-PLOT POSITION FINE-ADJUST C DI, DJ C MAP(15) = T1 C T1 GRID-LENGTH IN FAX UNITS AS A REAL NUMBER C C ALL ORIGINS ARE MEASURED FROM THE BACKGROUND MAP C IF ANY, AT A POINT 1800 UNITS TO THE LEFT OF THE FAX EDGE C IN SCAN LINE UNITS. C FINAL FAX START WILL BE AT RIGHT EDGE OF PRODUCT C CONTOUR-ADJUST IS NORMALLY MEASURED FROM THE LOWER C LEFT CORNER OF THE BACKGROUND. A LINE WITH HLL=P C WILL HAVE ZERO ADJUST. C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . C LABEL - INTEGER*4 LABEL(2048) C LABEL IS AN ARRAY CONTAINING 2 WORDS PER ENTRY OF THE FORM: C VFD 15/J, 1/FLAG, 3/PRIORITY, 13/I C VFD 32/4HLITERAL C C THE LITERAL STRING TERMINATES BY '$' IF LESS THAN 4; C THE LABEL-ARRAY IS TERMINATED BY A PAIR OF ZERO WORDS. C IF(J .GE. 7400) THEN C THIS LABEL-ITEM IS PUT IN THE CHART-LABEL RECORD. C IF(IOR(LABEL(1),LABEL(2)) .EQ. 0) THEN C THERE IS NO LABEL-ARRAY TEXT-DATA TO PROCESS; C IF(LABEL(1) .EQ. -1) THEN C LABEL-ARRAY DATA IS OUT ON FILE 55; C ELSE C LABEL-ARRAY IS FOUND IN LABELLED COMMON C AND DOES NOT EXCEED 1024 ITEMS. C INDEX - INTEGER*4 INDEX(2,3) C INDEX SPECIFIES THE DIMENSIONS OF THE GRID TO BE CONTOURED C THE FORM OF INDEX IS: C E0= GRID COUNT C E1= P = MAX VALUE OF HALF LINE LENGTH C P IS THE SYMMETRY GRID LINE C E2=0 IF ODD C =1 IF EVEN; C E3=RECTANGULAR FLAG C E4,E5= THE LINE ORIGIN,THE HALF LINE LENGTH C (ONLY ONE E4,E5 ENTRY IS REQUIRED IF RECTANGULAR) C ETC C IF(E3.EQ.0 .OR. E3.EQ.1) THERE MUST BE A COMPLETE TABLE C IF E3 IS 1 THE POLYGON IS DRAWN TO THE BNDRY C IF E3 IS NEG THE RECT WILL BE DRAWN THE BNDRY C IF ODD IS 0 ONE EXTRA ROW IS DONE C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . C NFLDS - INTEGER*4 NFLDS C NFLDS IS THE NUMBER OF GRID FIELDS TO CONTOUR C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . C FOUR WORD ENTRY PER GRIDPOINT DATA SET TO BE CONTOURED ... C FLD, DASH, OFFSET, SHADE C FLD IS THE LOC OF THE GRID ARRAY C DASH IS THE DASH MASK /DASH WEIGHT IN HALF WORDS C OFFSET IS WEIGHT/ OFFSET IN HALF WORDS C WEIGHT IS 0 OR 2 FOR LINE WEIGHT C IF WEIGHT IS NEGATIVE,NO NEGATIVE VALUED CONTOURS C OFFSET MOVES THIS CONTOUR - SCAN UNITS TO RIGHT C IF THE OFFSET IS LESS THAN 100 AND C GREATER THAN ZERO, IT IS CONSIDERED TO BE THE C MAXIMUM CONTOUR TO BE ALLOWED C SHADE IS THE SHADE MASK /AND THE SHADE MATCH IN HALF WDS C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . C FLD1 - REAL FLD1(*) --- 1ST GRIDPOINT FIELD C DASH1 - INTEGER DASH1(2) --- DASHING SPECS C OFSET1 - INTEGER OFSET1(2) --- LINE WEIGHT/ADJ X-POSIT C SHAD1 - INTEGER SHAD1(20) --- SHADING SPECS C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . C FLD2 - REAL FLD2(*) --- 2ND GRIDPOINT FIELD C DASH2 - INTEGER DASH2(2) --- DASHING SPECS C OFSET2 - INTEGER OFSET2(2) --- LINE WEIGHT/ADJ X-POSIT C SHAD2 - INTEGER SHAD2(20) --- SHADING SPECS C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . C FLD3 - REAL FLD3(*) --- 3RD GRIDPOINT FIELD C DASH3 - INTEGER DASH3(2) --- DASHING SPECS C OFSET3 - INTEGER OFSET3(2) --- LINE WEIGHT/ADJ X-POSIT C SHAD3 - INTEGER SHAD3(20) --- SHADING SPECS C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . C FLD4 - REAL FLD4(*) --- 4TH GRIDPOINT FIELD C DASH4 - INTEGER DASH4(2) --- DASHING SPECS C OFSET4 - INTEGER OFSET4(2) --- LINE WEIGHT/ADJ X-POSIT C SHAD4 - INTEGER SHAD4(20) --- SHADING SPECS C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . C C OUTPUT ARGUMENTS: C IRET_CNT - INTEGER RETURN CODE C = -1 NORMAL C = 0 OUTPUT TROUBLE C = 1 BACKGROUND TROUBLE c image - contains contour output c imagsiz_wrds - size of image C C SUBPROGRAMS CALLED: C LIBRARY: C GRAPHICS - C C EXIT STATES: C IRET_CNT= 0 - SUCCESSFUL RUN C C REMARKS: C C ATTRIBUTES: C LANGUAGE: fortran 90 C MACHINE: ibm C C$$$ C COMMON /ILCON/ IL(15) C INTEGER LMAX PARAMETER (LMAX=1024) INTEGER LMAX2 PARAMETER (LMAX2 = 2*LMAX) C INTEGER IRET_CNT INTEGER IMAGE(IMAGSIZ_WRDS) C INTEGER IWINDOW(30) INTEGER MAP(15) INTEGER LABEL(LMAX2) C INTEGER INDEX(6) INTEGER NFLDS REAL FLD1(*) INTEGER DASH1(2), OFSET1(2), SHAD1(20) REAL FLD2(*) INTEGER DASH2(2), OFSET2(2), SHAD2(20) REAL FLD3(*) INTEGER DASH3(2), OFSET3(2), SHAD3(20) REAL FLD4(*) INTEGER DASH4(2), OFSET4(2), SHAD4(20) C COMMON / DGNBIN / VECBIN,MAXBIN,IMDEX,ITOTWD INTEGER VECBIN(409800) C COMMON / DASH / LDOUBLE,DASHFG,DASHMK(2),IDASH,SHADNO,SHADMK(20) LOGICAL LDOUBLE LOGICAL DASHFG INTEGER DASHMK INTEGER IDASH INTEGER SHADNO INTEGER SHADMK C LOGICAL WORKL(648400) REAL WORKZ(324200) C C ... WORKZ AND WORKL ARE NEEDED BY BCNTOR .... C REAL FLDCNT(16900) REAL T1 SAVE C C--------------------- PROGRAM STARTS ------------------------------- C print*,' at top of cntri' DO I = 1, 15 IL(I) = MAP(I) ENDDO C MAXBIN = 409800 NINDX = 0 NDVD = 2 NDIV = 4 IEXIT = 0 T1 = FLOAT(MAP(15))/ 1000. PRINT *,' ***T1=', T1 C ILMAX = IABS(INDEX(4)) JLMAX = IABS(INDEX(1)) PRINT *,' ILMAX=', ILMAX PRINT *,' JLMAX=', JLMAX C IJTEMP = ILMAX * JLMAX PRINT *,' IJTEMP=', IJTEMP C NOLINES = IWINDOW(4) NOWIDTH = IWINDOW(15) NOPIXELS = IWINDOW(16) C PRINT *,'SHAD1=',SHAD1(1),' ',SHAD1(2),' ',SHAD1(3),' ',SHAD1(4) PRINT *,'SHAD2=',SHAD2(1),' ',SHAD2(2),' ',SHAD2(3),' ',SHAD2(4) C C INITIALIZATION C IMZ = (ILMAX-1)*NDIV + 1 IML = 2*IMZ-1 print*,' ndiv = ',ndiv,' imz = ',imz,' iml = ',iml print*,' nflds = ',nflds C LDOUBLE = .FALSE. IDASH = 0 C DO I = 1, NFLDS C IF (I .EQ. 1) THEN IF (DASH1(1).EQ.0) THEN DASHFG = .FALSE. DASHMK(1) = 0 DASHMK(2) = 0 ELSE DASHFG = .TRUE. DASHMK(1) = DASH1(1) DASHMK(2) = DASH1(2) ENDIF PRINT *,' DASH1=',DASH1(1),' ',DASH1(2) LTEMP = 0 DO II = 1, 20 IF (SHAD1(II).EQ.0) GOTO 310 SHADMK(II) = SHAD1(II) LTEMP = II ENDDO 310 CONTINUE SHADNO = LTEMP/2 PRINT *,' SHADNO=', SHADNO PRINT *,' SHADMK=',SHAD1(1),' ',SHAD1(2) C DO K = 1, IJTEMP FLDCNT(K) = FLD1(K) ENDDO C IOFSET = IABS(OFSET1(1)) IF (IOFSET .EQ. 2) THEN LDOUBLE=.TRUE. ELSE LDOUBLE=.FALSE. ENDIF C C ELSEIF (I .EQ. 2) THEN IF (DASH2(1).EQ.0) THEN DASHFG = .FALSE. DASHMK(1) = 0 DASHMK(2) = 0 ELSE DASHFG = .TRUE. DASHMK(1) = DASH2(1) DASHMK(2) = DASH2(2) ENDIF PRINT *,' DASH2=',DASH2(1),' ',DASH2(2) LTEMP = 0 DO II = 1, 20 IF (SHAD2(II).EQ.0) GOTO 320 SHADMK(II) = SHAD2(II) LTEMP = II ENDDO 320 CONTINUE SHADNO = LTEMP/2 PRINT *,' SHADNO=', SHADNO PRINT *,' SHADMK=',SHAD2(1),' ',SHAD2(2) C DO K = 1, IJTEMP FLDCNT(K) = FLD2(K) ENDDO C IOFSET = IABS(OFSET2(1)) IF (IOFSET .EQ. 2) THEN LDOUBLE=.TRUE. ELSE LDOUBLE=.FALSE. ENDIF C ELSEIF (I .EQ. 3) THEN IF (DASH3(1).EQ.0) THEN DASHFG = .FALSE. DASHMK(1) = 0 DASHMK(2) = 0 ELSE DASHFG = .TRUE. DASHMK(1) = DASH3(1) DASHMK(2) = DASH3(2) ENDIF LTEMP = 0 DO II = 1, 20 IF (SHAD3(II).EQ.0) GOTO 330 SHADMK(II) = SHAD3(II) LTEMP = II ENDDO 330 CONTINUE SHADNO = LTEMP/2 C DO K = 1, IJTEMP FLDCNT(K) = FLD3(K) ENDDO C IOFSET = IABS(OFSET3(1)) IF (IOFSET .EQ. 2) THEN LDOUBLE=.TRUE. ELSE LDOUBLE=.FALSE. ENDIF C C ELSEIF (I .EQ. 4) THEN IF (DASH4(1).EQ.0) THEN DASHFG = .FALSE. DASHMK(1) = 0 DASHMK(2) = 0 ELSE DASHFG = .TRUE. DASHMK(1) = DASH4(1) DASHMK(2) = DASH4(2) ENDIF LTEMP = 0 DO II = 1, 20 IF (SHAD4(II).EQ.0) GOTO 340 SHADMK(II) = SHAD4(II) LTEMP = II ENDDO 340 CONTINUE SHADNO = LTEMP/2 C DO K = 1, IJTEMP FLDCNT(K) = FLD4(K) ENDDO C IOFSET = IABS(OFSET4(1)) IF (IOFSET .EQ. 2) THEN LDOUBLE=.TRUE. ELSE LDOUBLE=.FALSE. ENDIF C C ENDIF C C ................ WORK ON CONTOURS ................. C CALL BCNTOR(IMAGE,NOWIDTH,NOLINES,FLDCNT,ILMAX,JLMAX, & NDVD,NDIV,WORKZ,IMZ,WORKL,IML,MAP,IEXIT) C ENDDO C RETURN END