C$$$ MAIN PROGRAM DOCUMENTATION BLOCK
C . . . .
C MAIN PROGRAM: BULLS_FDWNDTRX
C PRGMMR: VUONG ORG: NP11 DATE: 2005-08-03
C
C ABSTRACT: THIS PROGRAM CREATES BULLETINS OF FORECAST WINDS AND
C TEMPS FOR UP TO 15 LEVELS FOR U.S. AND PACIFIC REGION AND CANADA.
C THE PRIMARY (RMP) IS RUN.
C EACH BULLETIN OF A SET REPRESENTS A 6, 12 OR 24 HR FCST.
C THE PROGRAM GENERATED ARE THE FOLLOWING BULLETINS;
C FBUS31-39 FBPA31-39
C FBAK31-39 FBCN01-3
C THE STATION FILE (FDWND.STNLIST) IS KEYED TO INDICATE WHICH BULLETIN
C EACH STATION BELONGS IN. THE WIND SPEED (TEN OF DEGREES), WIND DIRECTION
C (KNOTS) & TEMPERATURE(CELSIUS) IN THE FORM (DDff+TT) FOR EACH STATION
C AND LEVELS APPEAR IN THE BULLETIN. WHERE DD IS THE WIND DIRECTION,
C ff IS THE WIND SPEED, AND TT IS THE TEMPERATURE
C THE FORECAST INPUT DATA IS NAM MODEL OPERATIONAL GRIB GRID 221
C FORECAST FILES U,V,& T FIELDS, 15 LEVELS: 1000', 1500', 2000', 3000',
C 6000', 9000', 12000', 15000' + 500, 400, 300, 250, 200, 150 AND 100MB
C
C THE INPUT STATION RECORD FOR EACH STATION CONTAINS STN ELEVATION
C AND LATITUDE/LONGITUDE POSITION.
C
C PROGRAM HISTORY LOG:
C 86-01-03 CAVANAUGH
C 87-12-07 CAVANAUGH XDAM TO VSAM FOR RGL FORECAST FILES
C 88-02-02 FARLEY XDAM TO VSAM FOR ERL/AVN FORECAST FILES
C 88-05-04 CAVANAUGH CHANGE TO READ PROD TIME FROM FT90F001
C 89-06-01 CAVANAUGH INCREASED NR OF MAXSTNS
C MODIFIED TO ALLOW FOR 4 LETTER IDENTIFIERS
C 96-07-11 R.E.JONES CONVERT TO RUN ON CRAY WITH GRIB INPUT FILES
C 96-12-11 JOHNSON CORRECTED SIGN FOR POSITIVE TEMPS (2B TO 7C).
C OSO NEEDS SIGN TO BE A 4F (SOLID BAR).
C 97-06-11 G. DIMEGO CONVERT TO RUN OFF EARLY NAM GRIB INPUT FILES
C USING GRID #104 SUPER-C GRID
C 98-04-29 VUONG REPLACED W3FS11, W3FS13, W3FS15 WITH CALLS TO
C W3MOVDAT AND REMOVED W3LOG
C 98-08-28 J.A.ATOR REWORKED LOGIC TO REPLACE GOTOS WITH IF-THEN-ELSE
C 98-08-31 GILBERT REMOVED DATE CHECK AT THE BEGINNING OF PROGRAM
C 98-09-16 VUONG CONVERT TO RUN ON GRIB INPUT FILES: GRID TYPE 6
C (LFM FORCAST) OR GRID TYPE 104 (NGM SUPER C GRID)
C 99-12-16 VUONG CONVERTED TO RUN ON THE IBM SP AND REPLACED
C GETGB1 WITH CALLS TO GETGB AND GETGBP
C 00-04-14 VUONG CHANGE THE TIME ON THE BULLETIN HEADER TO THE
C TIME OF THE BULLETIN IS MADE
C 01-05-15 VUONG MODIFIED THE PROGRAM TO RUN ON THE NAM
C FORECAST MODEL DATA FROM THE GRIB GRID 221 FILES.
C THE PROGRAM WAS SETUP TO RUN IN THE TWO CYCLES
C T00Z AND T12Z.
C 03-05-12 VUONG CORRECTED THE INPUT ARGUMENTS PASS TO THE SUBROUTINE
C W3MOCDAT
C 04-06-29 VUONG REMOVED DUPLICATE STATIONS IN FDWND.STNLST AND MODIFIED
C THE PROGRAM TO ADD 4 MORE LEVELS FOR PACIFIC REGION
C AND CHANGED THE WMO HEADERS FD TO FB AND KWBC TO KWNO
C AND ADD AWIPS ID. THE PROGRAM SETUP TO RUN 4 TIMES PER
C DAY (T00Z, T06Z, T12Z AND T18Z).
C 05-08-03 VUONG CHANGED FOR THE USE TIMES SPECIFIED ON WIND AND TEMPERATURES
C ALOFT 6 AND 12 HOUR FORECAST BULLETINS AND REMOVED OF 1000 AND
C 1500 FOOT LOW LEVELS FOR THE LANAI REPORT (LNY) FROM 6, 12
C AND 24 HOUR UPPER WINDS AND TEMP ALOFT FORECAST BULLETINS
C 06-11-27 VUONG MODIFIED THE PROGRAM TO USE LINEAR INTERPOLATION
C 12-11-02 VUONG MODIFIED VARIABLES NNPOS AND CHANGED
C VARIABLE ENVVAR TO CHARACTER*6
C
C USAGE:
C INPUT FILES:
C FORT.05 FBWND_CONUS.STNLIST STATION DIRECTORY
C
C - NAM GRIB GRID TYPE 221 (LAMBERT CONFORMAL):
C AWIPS GRID TYPE 221 DIMENSIONS 349 x 277 = 96673
C FORT.11 /COM/NAM/PROD/NAM.${PDY}/NAM.${CYCLE}.AWIP3206.TM00
C FORT.12 /COM/NAM/PROD/NAM.${PDY}/NAM.${CYCLE}.AWIP3212.TM00
C FORT.13 /COM/NAM/PROD/NAM.${PDY}/NAM.${CYCLE}.AWIP3224.TM00
C - NAM INDEX FILES FOR GRIB GRID 221:
C FORT.31 /COM/NAM/PROD/NAM.${PDY}/NAM.${CYCLE}.AWIP32I06
C FORT.32 /COM/NAM/PROD/NAM.${PDY}/NAM.${CYCLE}.AWIP32I12
C FORT.33 /COM/NAM/PROD/NAM.${PDY}/NAM.${CYCLE}.AWIP32I24
C
C WHERE PDY = YYYYMMDD, YYYY IS THE YEAR, MM IS THE MONTH,
C DD IS THE DAY OF THE MONTH
C AND
C CYCLE = T00Z, T06Z, T12Z, T18Z
C
C OUTPUT FILES:
C FORT.06 ERROR MESSAGES
C FORT.51 BULLETIN RECORDS FOR TRANSMISSION
C
C SUBPROGRAMS CALLED: (LIST ALL CALLED FROM ANYWHERE IN CODES)
C LIBRARY:
C W3AI15 WXAI19 W3FC03 W3FI01
C GETGB GETGBP (FOR GRIB FILES)
C W3FT01 W3TAGE XMOVEX XSTORE W3UTCDAT
C
C EXIT STATES:
C COND = 110 STN DIRECTORY READ ERR (CONSOLE MSG)
C 1050 NO DATA (FIELD ID IS PRINTED)(FT06 + CONSOLE)
C 1060 NO DATA (FIELD ID IS PRINTED)(FT06 + CONSOLE)
C 1070 NO DATA (FIELD ID IS PRINTED)(FT06 + CONSOLE)
C 1080 NO DATA (FIELD ID IS PRINTED)(FT06 + CONSOLE)
C 1090 NO DATA (FIELD ID IS PRINTED)(FT06 + CONSOLE)
C ALL ARE FATAL
C PLUS W3LIB SUB-RTN RETURN CODES
C
C REMARKS:
C
C DATA CARDS FOR 'WLL' AND 'WYA' WERE MODIFIED TO "FIT" INTO
C THE LFM GRID. THE IBM/HDS MACHINES ALLOWED THIS CODE TO "GO
C OFF THE GRID GRACEFULLY AND EVIDENTLY SEND OUT ERRONEOUS DATA
C FOR YEARS. THE CRAY WAS NOT SO FRIENDLY! COULDN'T GET ANY
C HELP FROM NWSH/OM REGARDING THIS DILEMA, SO ADJUSTED THE
C LATITUDE VALUES OURSELVES TO GET THIS CODE CONVERTED TO THE
C CRAY. THE FOLLOWING CHANGES WERE MADE:
C FOR 'WLL', THE LAT WAS CHANGED FROM 82.00 TO 78.00
C FOR 'WYA', THE LAT WAS CHANGED FROM 84.00 TO 80.00
C REJ/MAF.
C
C ATTRIBUTES:
C LANGUAGE: F90 FORTRAN
C MACHINE: IBM RS600 SP
C
C$$$
C
PARAMETER (MXSIZE= 96673)
PARAMETER (MAXSTN=800)
PARAMETER (IMAX=349,JMAX=277)
C
REAL ALAT(MAXSTN),ALON(MAXSTN)
REAL ISTN(MAXSTN),JSTN(MAXSTN),XI,XJ
REAL ERAS(3),FHOUR
REAL RFLD(MXSIZE),RINTRP(IMAX,JMAX)
REAL ALAT1, ELON1, DX, ELONV, ALATAN, IPOLE, JPOLE
C
C...MAX NR STNS FOR READ-END SHOULD BE GT ACTUAL NR OF STNS ON STN FILE
INTEGER IELEV(MAXSTN),IRAS(3),KTAU(3)
INTEGER ITIME(8),NDATE(8),MDATE(8)
INTEGER JGDS(100),KGDS(100),JREW,KBYTES
INTEGER KPDS(27),MPDS(27),KREW
INTEGER KSTNU(MAXSTN,15)
INTEGER LMTLWR(7),LMTUPR(7),NTTT
C...NPOS(ITIVE) IS TRANSMISSION SIGN 7C MASK FOR TEMP
INTEGER ICKYR,ICKMO,ICKDAY,ICKHR
INTEGER KSTNV(MAXSTN,15),KSTNT(MAXSTN,15)
INTEGER IDWD1H(3),IDWD2H(3)
INTEGER IDWD1P(3),IDWD2P(3)
INTEGER IDWD2(15),NHGTP(15)
C
C...S,L,T,B ARE SUBSCRIPTS FOR SEQ NR OF STATION, LEVEL, TAU, BULLETIN
C... B IS COUNT OF BULTNS WITHIN TAU, BB IS COUNT WITHIN RUN
C
INTEGER S,L,T,B, BB
C
CHARACTER*6 NHGT6(15), AWIPSID(21)
CHARACTER*1 BSTART,BEND
CHARACTER*1 BULTN(1280)
CHARACTER*1 SPACE(1280)
CHARACTER*1 ETBETX,ETB,ETX,ICK,ICKX
CHARACTER*1 INDIC(MAXSTN),LF,MINUS
CHARACTER*1 MUSES(MAXSTN)
CHARACTER*1 SPC80(80),TSRCE,TMODE,TFLAG
CHARACTER*3 CRCRLF
CHARACTER*4 ITRTIM,STNID(MAXSTN),IVALDA
CHARACTER*1 NNPOS
CHARACTER*4 NFDHDG(21),NCATNR(21),NVALTM(12)
CHARACTER*9 NUSETM(12)
C
CHARACTER*8 IBLANK,IBSDA,IBSTI,ITRDA
CHARACTER*8 ITEMP(MAXSTN,15),IWIND(MAXSTN,15)
CHARACTER*8 NFILE,NTTT4,RF06,RF12,RF24
CHARACTER*6 ENVVAR
CHARACTER*80 FILEB,FILEI,SPCS,FILEO
C
CHARACTER*86 LINE73
CHARACTER*40 LN73A,NBUL1
CHARACTER*46 LN73B
CHARACTER*84 NBULHD
CHARACTER*34 NBUL2
CHARACTER*32 NBASHD
CHARACTER*60 NVALHD
C
LOGICAL ENDBUL,KBMS(MXSIZE)
C
EQUIVALENCE (ICK,ICKX)
EQUIVALENCE (RFLD(1),RINTRP(1,1))
EQUIVALENCE (NBULHD(1:1),NBUL1(1:1))
EQUIVALENCE (NBULHD(41:41),NBUL2(1:1))
EQUIVALENCE (LINE73(1:1),LN73A(1:1))
EQUIVALENCE (LINE73(41:41),LN73B(1:1))
EQUIVALENCE (SPCS,SPC80)
EQUIVALENCE (NTTT,NTTT4(1:1))
C
C PARAMETERS FOR GRID 221
C
C LATITUDE OF LOWER LEFT POINT OF GRID (POINT (1,1)
C
DATA ALAT1 /1.000/
DATA INDEX /1/
C
C EAST LONGITUDE OF OF LOWER LEFT POINT OF GRID (POINT (1,1)
C
DATA ELON1 /214.50/
C
C MESH LENGTH OF GRID IN METERS AT TANGENT LATITUDE
C
DATA DX /32463.41/
C
C THE ORIENTATION OF THE GRID
C
DATA ELONV /253.00/
C
C THE LATITUDE AT WHICH THE LAMBERT CONE IS TANGENT TO
C THE SPHERICAL EARTH
C
DATA NCYCLK/ 0 /
DATA LIN / 1 /
DATA ALATAN /50.00/
DATA IPOLE /174.507/
DATA JPOLE /307.764/
DATA CENLON /-107.00/
DATA XLAT1 /50.00/
C
DATA FHOUR /24.0/
DATA KTAU /06,12,24/
DATA LMTLWR/4,4,1,10,11,14,14/
DATA LMTUPR/13,13,10,15,15,15,15/
DATA IDWD1H/ 33, 34, 11/
DATA IDWD2H/ 103, 103, 103/
DATA IDWD1P/ 33, 34, 11/
DATA IDWD2P/ 100, 100, 100/
DATA IDWD2 / 305, 457, 610, 914,
1 1829, 2743, 3658, 4572,
2 500, 400, 300, 250,
3 200, 150, 100/
DATA NHGT6 /'1000 ','1500 ','2000 ','3000 ',
1 '6000 ','9000 ','12000 ','15000 ',
2 '18000 ','24000 ','30000 ','34000 ',
3 '39000 ','45000 ','53000'/
DATA NHGTP /5,5,6,6,6,6,6,6,6,6,6,6,6,6,5/
DATA BSTART/'B'/
DATA BEND /'E'/
DATA ETB /'>'/
DATA ETX /'%'/
DATA MINUS /'-'/
DATA SPC80 /80*' '/
DATA CRCRLF/'<<@'/
DATA IBLANK/' '/
DATA AWIPSID / 'FD1US1','FD1AK1','FD1HW1','FD1CN1','FD8HW7',
1 'FD8US7','FD8AK7','FD3US3','FD3AK3','FD3HW3',
2 'FD3CN3','FD9HW8','FD9US8','FD9AK8','FD5US5',
3 'FD5AK5','FD5HW5','FD5CN5','FD0HW9','FD0US9',
4 'FD0AK9'/
DATA NFDHDG/
1 'US31','AK31','HW31','CN31','HW37','US37',
2 'AK37','US33','AK33','HW33','CN33','HW38',
3 'US38','AK38','US35','AK35','HW35','CN35',
4 'HW39','US39','AK39'/
DATA NCATNR/
1 '6707','9087','1448','9874','1449','4809',
2 '1413','6726','9088','1450','9875','1451',
3 '4810','1415','6736','9089','1452','9876',
4 '1453','4811','1441'/
DATA NVALTM/
1 '0600','1200','0000','1200','1800','0600',
2 '1800','0000','1200','0000','0600','1800'/
DATA NUSETM/
1 '0200-0900','0900-1800','1800-0600',
2 '0800-1500','1500-0000','0000-1200',
3 '1400-2100','2100-0600','0600-1800',
4 '2000-0300','0300-1200','1200-0000'/
C
DATA RF06 /'6 HOURS '/
DATA RF12 /'12 HOURS'/
DATA RF24 /'24 HOURS'/
DATA LN73A /' '/
DATA LN73B /' <<@^^^'/
DATA NBUL1 /
1 '''10 PFB '/
DATA NBUL2/
1 'FB KWNO <<@^^^ <<@$'/
DATA NBASHD/'DATA BASED ON Z <<@@^^^'/
DATA NVALHD/
1 'VALID Z FOR USE - Z. TEMPS NEG ABV 24000<<@@^'/
C
NNPOS = CHAR(124)
LUGO = 51
CALL W3TAGB('BULLS_FDWNDTRX',2012,0138,0072,'NP11')
ENVVAR='FORT '
WRITE(ENVVAR(5:6),FMT='(I2)') LUGO
CALL GETENV(ENVVAR,FILEO)
OPEN(LUGO,FILE=FILEO,ACCESS='DIRECT',RECL=1281)
IREC=1
C...GET COMPUTER DATE-TIME & SAVE FOR DATA DATE VERIFICATION
CALL W3UTCDAT(ITIME)
C
C...READ AND STORE STATION LIST FROM UNIT 5
C...INDIC = INDICATOR BEGIN, OR END, BULTN ('B' OR 'E')
C...MUSES = USED IN MULTIPLE BULTNS (FOR SAME TAU) IF '+'
C
DO 25 I = 1, MAXSTN
READ(5,10,ERR=109,END=130) INDIC(I),MUSES(I),STNID(I),
& IELEV(I),ALAT(I),ALON(I)
25 CONTINUE
C
C///////////////////////////////////////////////////////////////////
10 FORMAT(A1,A1,A4,1X,I5,1X,F6.2,1X,F7.2)
C
C...ERROR
109 CONTINUE
CALL W3TAGE('BULLS_FDWNDTRX')
PRINT *,'STATION LIST READ ERROR'
CALL ERREXIT (110)
C////////////////////////////////////////////////////////////////////
C
130 CONTINUE
C
C CONVERT THE LAT/LONG COORDINATES OF STATION TO LAMBERT
C CONFORMAL PROJECTION I,J COORDINATES FOR GRID 221
C
NRSTNS = I-1
WRITE(6,'(A19,1X,I0)') ' NO. OF STATIONS = ',NRSTNS
C PRINT *,'STN-ID ALAT ALON ISTN JSTN'
DO 110 J = 1,NRSTNS
CALL W3FB11(ALAT(J),ALON(J),ALAT1,ELON1,DX,ELONV,ALATAN,
+ XI, XJ )
ISTN(J) = XI
JSTN(J) = XJ
C PRINT 111,STNID(J),ALAT(J),ALON(J),ISTN(J),JSTN(J)
111 FORMAT (3X,A3,2(2X,F8.2),2(2X,F8.3))
110 CONTINUE
C
C...END READ. COUNT OF STATIONS STORED
C
C...GET EXEC PARMS
C...PARM FIELD TAKEN OUT, NEXT 4 VALUES HARD WIRED
TMODE = 'M'
TSRCE = 'R'
TFLAG = 'P'
PRINT *,'SOURCE=',TSRCE,' MODE=',TMODE,' FLAG=',TFLAG
C
C**********************************************************************
C
C...READ PACKED DATA, UNPACK, INTERPOLATE, STORE IN STATION ARRAYS,
C... CREATE BULTN HDGS, INSERT STATION IN BULTNS, & WRITE BULTNS.
C
BB = 0
C
C...BEGIN TAU
C
DO 7000 ITAU=1, 3
C
WRITE(6,'(A6,1X,I0)') ' ITAU=',ITAU
T = ITAU
C
C SELECT FILE FOR TAU PERIOD (PRIMARY RUN)
C
IF (KTAU(ITAU).EQ.6) THEN
NFILE = RF06
LUGB = 11
LUGI = 31
ELSE IF (KTAU(ITAU).EQ.12) THEN
NFILE = RF12
LUGB = 12
LUGI = 32
ELSE
NFILE = RF24
LUGB = 13
LUGI = 33
ENDIF
C
WRITE(ENVVAR(5:6),FMT='(I2)') LUGB
CALL GETENV(ENVVAR,FILEB)
WRITE(ENVVAR(5:6),FMT='(I2)') LUGI
CALL GETENV(ENVVAR,FILEI)
CALL BAOPENR(LUGB,FILEB,IRET)
CALL BAOPENR(LUGI,FILEI,IRET)
PRINT 1025,NFILE, FILEB, FILEI
1025 FORMAT('NFILE= ',A8,2X,'GRIB FILE= ',A50,'INDEX FILE= ',A50)
C
C..................................
DO 2450 ITYP=1,3
C
C... SEE O.N. 388 FOR FILE ID COMPOSITION
C
DO 2400 L=1,15
C
C...USE SOME OF THE VALUES IN THE PDS TO GET RECORD
C
C MPDS = -1 SETS ARRAY MPDS TO -1
C MPDS(3) = GRID IDENTIFICATION (PDS BYTE 7)
C MPDS(5) = INDICATOR OF PARAMETER (PDS BYTE 9)
C MPDS(6) = INDICATOR OF TYPE OF LEVEL OR LAYER (PDS BYTE 10)
C MPDS(7) = HGT,PRES,ETC. OF LEVEL OR LAYER (PDS BYTE 11,12)
C MPDS(14) = P1 - PERIOD OF TIME (PDS BYTE 19)
C VALUES NOT SET TO -1 ARE USED TO FIND RECORD
C
JREW = 0
KREW = 0
MPDS = -1
C
MPDS(3) = 221
IF (L.LE.8) THEN
MPDS(5) = IDWD1H(ITYP)
C... HEIGHT ABOVE MEAN SEA LEVEL GPML
MPDS(6) = IDWD2H(ITYP)
ELSE
MPDS(5) = IDWD1P(ITYP)
C... PRESSURE IN HectoPascals (hPa) ISBL
MPDS(6) = IDWD2P(ITYP)
ENDIF
MPDS(7) = IDWD2(L)
MPDS(14) = KTAU(ITAU)
C
C... THE FILE ID COMPLETED.
C PRINT *,MPDS
C... GET THE DATA FIELD.
C
CALL GETGB(LUGB,LUGI,MXSIZE,JREW,MPDS,JGDS,
& KBYTES,KREW,KPDS,KGDS,KBMS,RFLD,IRET)
C WRITE(*,119) KPDS
119 FORMAT( 1X, 'MAIN: KPDS:', 3(/1X,10(I5,2X) ) )
C
C///////////////////////////////////////////////////////////////////////
C...ERROR
IF (IRET.NE.0) THEN
write(*,120) (MPDS(I),I=3,14)
120 format(1x,' MPDS = ',12(I0,1x))
WRITE(6,'(A9,1X,I0)') ' IRET = ',IRET
IF (IRET.EQ.96) THEN
PRINT *,'ERROR READING INDEX FILE'
CALL W3TAGE('BULLS_FDWNDTRX')
CALL ERREXIT (1050)
ELSE IF (IRET.EQ.97) THEN
PRINT *,'ERROR READING GRIB FILE'
CALL W3TAGE('BULLS_FDWNDTRX')
CALL ERREXIT (1060)
ELSE IF (IRET.EQ.98) THEN
PRINT *,'NUMBER OF DATA POINT GREATER',
* ' THAN MXSIZE'
CALL W3TAGE('BULLS_FDWNDTRX')
CALL ERREXIT (1070)
ELSE IF (IRET.EQ.99) THEN
PRINT *,'RECORD REQUESTED NOT FOUND'
CALL W3TAGE('BULLS_FDWNDTRX')
CALL ERREXIT (1080)
ELSE
PRINT *,'GETGB-W3FI63 GRIB UNPACKER',
* ' RETURN CODE'
CALL W3TAGE('BULLS_FDWNDTRX')
CALL ERREXIT (1090)
END IF
ENDIF
C
C...GET DATE-TIME FOR LATER BULTN HDG PROCESSING
C
ICKYR = KPDS(8) + 2000
ICKMO = KPDS(9)
ICKDAY= KPDS(10)
ICKHR = KPDS(11) * 100
IF (ICKHR.EQ.0000) ICYC=1
IF (ICKHR.EQ.0600) ICYC=2
IF (ICKHR.EQ.1200) ICYC=3
IF (ICKHR.EQ.1800) ICYC=4
IBSTIM=ICKHR
C
C...GET NEXT DAY - FOR VALID DAY AND 12Z AND 18Z BACKUP TRAN DAY
C...UPDATE TO NEXT DAY
NHOUR=ICKHR*.01
CALL W3MOVDAT((/0.,FHOUR,0.,0.,0./),
& (/ICKYR,ICKMO,ICKDAY,0,NHOUR,0,0,0/),NDATE)
CALL W3MOVDAT((/0.,FHOUR,0.,0.,0./),NDATE,MDATE)
C
C...12Z, 18Z CYCLE,BACKUP RUN,24HR FCST: VALID DAY IS DAY-AFTER-NEXT
C...NEXT DAY-OF-MONTH NOW STORED IN 'NDATE(3)'
C...NEXT DAY PLUS 1 IN 'MDATE(3)'
C
C...CONVERT DATA TO CONVENTIONAL UNITS:
C... WIND FROM METERS/SEC TO KNOTS (2 DIGITS),
C WIND DIRECTION IN TENS OF DEGREES (2 DIGITS),
C AND TEMP FROM K TO CELSIUS (2 DIGITS)
C
DO 1500 I=1,MXSIZE
C
IF (ITYP.EQ.3) THEN
RFLD(I)=RFLD(I)-273.15
ELSE
RFLD(I)=RFLD(I)*1.94254
ENDIF
C
1500 CONTINUE
C
DO 2300 S=1,NRSTNS
C
C INTERPOLATE GRIDPOINT DATA TO STATION.
C
CALL W3FT01(ISTN(S),JSTN(S),RINTRP,X,IMAX,JMAX,NCYCLK,LIN)
C WRITE(6,830) STNID(S),ISTN(S),JSTN(S),X
830 FORMAT(1X,'STN-ID = ', A4,3X,'SI,SJ = ', 2(F5.1,2X), 1X,
A 'X = ', F10.0)
C
C...INTERPOLATION COMPLETE FOR THIS STATION
C
C...CONVERT WIND, U AND V TO INTEGER
C
IF (ITYP.EQ.1) THEN
KSTNU(S,L)=X*100.0
ELSE IF (ITYP.EQ.2) THEN
KSTNV(S,L)=X*100.0
C...CONVERT TEMP TO I*2
ELSE IF (ITYP.EQ.3) THEN
KSTNT(S,L)=X*100.0
ENDIF
C
2300 CONTINUE
C...END OF STATION LOOP
C...................................
C
2400 CONTINUE
C...END OF LEVEL LOOP
C...................................
C
2450 CONTINUE
C...END OF DATA TYPE LOOP
C...................................
C
C...INTERPOLATED DATA FOR ALL STATIONS,1 TAU, NOW ARRAYED IN KSTNU-V-T.
C***********************************************************************
C
C...CONVERT WIND COMPONENTS TO DIRECTION AND SPEED
C
C.................................
C...BEGIN STATION
C
DO 3900 S=1,NRSTNS
C.................................
DO 3750 L=1,15
C
C...PUT U & V WIND COMPONENTS IN I*4 WORK AREA
IRAS(1)=KSTNU(S,L)
IRAS(2)=KSTNV(S,L)
C...FLOAT U & V
ERAS(1)=FLOAT(IRAS(1))*.01
ERAS(2)=FLOAT(IRAS(2))*.01
C
C...CONVERT TO WIND DIRECTION & SPEED
C
CALL W3FC03( ALON(S),ERAS(1),ERAS(2),CENLON,XLAT1,
1 DD, SS )
C
C...WITH DIR & SPEED IN WORK AREA, PLACE TEMPERATURE -TT- IN WORK
IRAS(3)=KSTNT(S,L)
TT=FLOAT(IRAS(3))*.01
C
C...DIRECTION, SPEED & TEMP ALL REQUIRE ADDITIONAL TREATMENT TO
C MEET REQUIREMENTS OF BULLETIN FORMAT
C
NDDD=(DD+5.0)/10.0
C...WIND DIRECTION ROUNDED TO NEAREST 10 DEGREEES
C
C...THERE IS A POSSIBILITY WIND DIRECTION NOT IN RANGE 1-36
IF ((NDDD.GT.36).OR.(NDDD.LE.0)) THEN
NDDD = MOD(NDDD, 36)
IF (NDDD.LE.0) NDDD = NDDD + 36
ENDIF
NSSS=SS+0.5
C
C...WIND SPEED ROUNDED TO NEAREST KNOT
C...FOR SPEED, KEEP UNITS AND TENS ONLY, WIND SPEEDS OF 100
C THROUGH 199 KNOTS ARE INDICATED BY SUBTRACTING 100 FROM
C THE SPEED AND ADDING 50 TO DIRECTION.
C
C...WIND SPEEDS GREATER THAN 199 KNOTS ARE INDICATED AS A
C FORECAST SPEED OF 199 KNOTS AND ADDING 50 TO DIRECTION.
C
IF (NSSS.GT.199) THEN
NSSS=99
NDDD=NDDD+50
C...SPEED GT 99 AND LE 199 KNOTS
ELSE IF (NSSS.GT.99) THEN
NSSS=NSSS-100
NDDD=NDDD+50
C
C...SPEED LT 5 KNOTS - CONSIDERED CALM
ELSE IF (NSSS.LT.5) THEN
NSSS=0
NDDD=99
ENDIF
C
C...COMBINE DIR & SPEED IN ONE WORD I*4
NDDSS=(NDDD*100)+NSSS
C
C...STORE IN ASCII IN LEVEL ARRAY, WIND FOR ONE STATION
CALL W3AI15(NDDSS,IWIND(S,L),1,4,MINUS)
C
C...TEMP NEXT. IF POSITIVE ROUND TO NEAREST DEGREE, CONV TO ASCII
NTTT = TT
IF (TT.LE.-0.5) NTTT = TT - 0.5
IF (TT.GE.0.5) NTTT = TT + 0.5
CALL W3AI15(NTTT,NTTT,1,3,MINUS)
IF (TT.GT.-0.5) NTTT4(1:1) = NNPOS(1:1)
C...SIGN & 2 DIGITS OF TEMP NOW IN ASCII IN LEFT 3 BYTES OF NTTT
C
ITEMP(S,L)(1:3) = NTTT4(1:3)
C
3750 CONTINUE
C...END LEVEL (WIND CONVERSION)
C.................................
C
C...AT END OF LVL LOOP FOR ONE STATION, ALL WIND & TEMP DATA IS ARRAYED,
C... IN ASCII, IN IWIND (4 CHARACTER DIR & SPEED) AND ITEMP (3 CHAR
C... INCL SIGN FOR 1ST 10 LVLS, 2 CHAR WITH NO SIGN FOR 5 UPPER LVLS)
C ABOVE 24,000 FEET, THE SIGN IS OMITTED SINCE TEMPERATURES ARE NEGATIVE.
C
C...BEFORE INSERTING INTO BULTN, TEMPS FOR LVLS OTHER THAN 3000'
C... WHICH ARE LESS THAN 2500' ABOVE STATION MUST BE ELIMINATED.
C... (TEMPS FOR 3000' ARE NOT TRANSMITTED)
C...WINDS ARE BLANKED FOR LVLS LESS THAN 1500' ABOVE STATION.
C
IF (IELEV(S).GT.9500) ITEMP(S,7) = IBLANK
IF (IELEV(S).GT.6500) ITEMP(S,6) = IBLANK
IF (IELEV(S).GT.3500) ITEMP(S,5) = IBLANK
ITEMP(S,4)=IBLANK
ITEMP(S,3)=IBLANK
ITEMP(S,2)=IBLANK
ITEMP(S,1)=IBLANK
C
IF (IELEV(S).GT.10500) IWIND(S,7) = IBLANK
IF (IELEV(S).GT.7500) IWIND(S,6) = IBLANK
IF (IELEV(S).GT.4500) IWIND(S,5) = IBLANK
IF (IELEV(S).GT.1500) IWIND(S,4) = IBLANK
IF (IELEV(S).EQ.1308) THEN
IWIND(S,1) = IBLANK
IWIND(S,2) = IBLANK
END IF
C
C...DATA FOR 1 STATION, 15 LVLS, 1 TAU NOW READY FOR BULTN LINE
C
3900 CONTINUE
C...END STATION (WIND CONVERSION)
C
C...DATA FOR ALL STATIONS, ONE TAU, NOW READY FOR BULTN INSERTION
C**********************************************************************
C*********************************************************************
C
C...BULLETIN CREATION
C...REACH THIS POINT ONCE PER TAU
C...B IS BULTN CNT FOR TAU, BB CUMULATIVE BULTN CNT FOR RUN,
C... S IS SEQ NR OF STN.
C... (NOT NEEDED FOR U.S. WHICH IS SET AT #1.)
B = 0
S = 0
ENDBUL = .FALSE.
C
DO 6900 J = 1,7
C.......................................................................
C
C...UPDATE STATION COUNTER
C
4150 S = S + 1
C
ICKX=INDIC(S)
IF (ICK(1:1).EQ.BSTART(1:1)) THEN
C...GO TO START, OR CONTINUE, BULTN
C
C...BEGIN BULLETIN
C
C
B = B + 1
BB = BB + 1
C***********************************************************************
C
C...PROCESS DATE-TIME FOR HEADINGS
C
IF (BB.EQ.1) THEN
C...............................
C...ONE TIME ENTRIES
C
C...TRAN HDGS
ITRDAY=ITIME(3)
IBSDAY=ICKDAY
WRITE(ITRTIM(1:4),'(2(I2.2))') ITIME(5), ITIME(6)
C
IF (TMODE.EQ.'T') THEN
C...BACKUP
IF (ICYC.EQ.3.OR.ICYC.EQ.4) THEN
C...TRAN DAY WILL BE NEXT DAY FOR 12Z, 18Z CYCLE BACKUP
ITRDAY=NDATE(3)
IF (ICYC.EQ.4.AND.T.EQ.3) IVLDAY=MDATE(3)
ENDIF
ENDIF
C...END TRAN BACKUP DAY-HOUR
C
C...PLACE TRAN & BASE DAY-HOUR IN HDGS
CALL W3AI15(ITRDAY,ITRDA,1,2,MINUS)
CALL W3AI15(IBSDAY,IBSDA,1,2,MINUS)
CALL W3AI15(IBSTIM,IBSTI,1,4,MINUS)
C
NBUL2(13:14) = ITRDA(1:2)
NBUL2(15:18) = ITRTIM(1:4)
C
NBASHD(15:16) = IBSDA(1:2)
NBASHD(17:20) = IBSTI(1:4)
ENDIF
C
C INSERT AWIPS ID INTO BULLETIN HEADER
C
C ****************************************************************
C ****************************************************************
C IF REQUIRED TO INDICATE THE SOURCE FOR THESE FD BULLETINS
C REMOVE THE COMMENT STATUS FROM THE NEXT TWO LINES
C ****************************************************************
C ****************************************************************
C
C...END ONE-TIME ENTRIES
C............................
C
C...BLANK OUT CONTROL DATE AFTER 1ST BULTN
IF (BB.EQ.2) NBULHD(13:20) = SPCS(1:8)
C
C...CATALOG NUMBER (AND 'P' OR 'B' FOR PRIMARY OR BACKUP RUN)
NBULHD(8:8) = TFLAG
NBULHD(4:7) = NCATNR(BB)(1:4)
NBULHD(43:46) = NFDHDG(BB)(1:4)
C
C INSERT AWIPS ID INTO BULLETIN HEADER
C
NBUL2(25:30) = AWIPSID(BB)(1:6)
C...END CATALOG NR
C
C...END TRAN HDGS
C.....................................................................
C
C...VALID-USE HDGS
IF (TMODE.EQ.'T') THEN
C...BACKUP DAY-HOURS WILL BE SAME AS PRIMARY RUN OF OPPOSITE CYCLE
IVLDAY=NDATE(3)
IF (ICYC.EQ.1.AND.T.EQ.1) IVLDAY=IBSDAY
IF (ICYC.EQ.4.AND.T.EQ.3) IVLDAY=NDATE(3)
C
C...SET POINTER OPPOSITE (USE WITH T -RELATIVE TAU- TO SET HOURS)
IF (ICYC.EQ.1) KCYC=2
IF (ICYC.EQ.3) KCYC=1
ELSE
IVLDAY=IBSDAY
IF (T.EQ.3) IVLDAY=NDATE(3)
IF (ICYC.EQ.3.AND.T.EQ.2) IVLDAY=NDATE(3)
IF (ICYC.EQ.4) IVLDAY=NDATE(3)
ENDIF
C...END BACKUP DAY-HOUR.
C
C...CONVERT TO ASCII AND PLACE IN HDGS
CALL W3AI15(IVLDAY,IVALDA,1,2,MINUS)
NVALHD(7:8) = IVALDA(1:2)
IITAU = ITAU
IF (ICYC.EQ.2) IITAU = ITAU + 3
IF (ICYC.EQ.3) IITAU = ITAU + 6
IF (ICYC.EQ.4) IITAU = ITAU + 9
NVALHD(9:12) = NVALTM(IITAU)(1:4)
NVALHD(25:33) = NUSETM(IITAU)(1:9)
C
C...END VALID-USE HDGS
C
C...MOVE WORK HDGS TO BULTN O/P (TRAN, BASE, VALID, HEIGHT HDGS)
NEXT=0
CALL WXAI19(NBULHD,74,BULTN,1280,NEXT)
C PRINT *,(NBULHD(L:L),L=41,70)
CALL WXAI19(NBASHD,28,BULTN,1280,NEXT)
C PRINT *,(NBASHD(L:L),L=1,25)
CALL WXAI19(NVALHD,60,BULTN,1280,NEXT)
CALL WXAI19('<<@',3,BULTN,1280,NEXT)
C PRINT *, (NVALHD(L:L),L=1,55)
LINE73(1:73) = SPCS(1:73)
LINE73(1:2) = 'FT'
NPOS1 = 5
DO 4500 N = LMTLWR(J), LMTUPR(J)
IF (N.EQ.8 .AND. J.NE.3) CYCLE
IF (J.LE.2) THEN
IF ((N.GT.4).AND.(N.LE.6)) THEN
NPOS1 = NPOS1 + 2
ELSE IF ((N.EQ.7).OR.(N.GE.11)) THEN
NPOS1 = NPOS1 + 1
ELSE IF ((N.EQ.9).OR.(N.EQ.10)) THEN
NPOS1 = NPOS1 + 2
ENDIF
ELSE IF (J.EQ.3) THEN
IF (N.LE.3) THEN
NPOS1 = NPOS1
ELSE IF (N.EQ.4) THEN
NPOS1 = NPOS1 - 1
ELSE IF ((N.GE.5).AND.(N.LE.6)) THEN
NPOS1 = NPOS1 + 2
ELSE IF (N.EQ.7) THEN
NPOS1 = NPOS1 + 1
ELSE IF (N.GT.7) THEN
NPOS1 = NPOS1 + 2
ENDIF
ELSE IF (J.GT.3) THEN
IF (N.EQ.10) THEN
NPOS1 = NPOS1 + 2
ELSE IF (N.GT.10) THEN
NPOS1 = NPOS1 + 1
ENDIF
END IF
NPOS2 = NPOS1 + 4
LINE73(NPOS1:NPOS2) = NHGT6(N)(1:5)
NPOS1 = NPOS1 + NHGTP(N)
4500 CONTINUE
C PRINT *,(LINE73(II:II),II=1,NPOS2)
CALL WXAI19(LINE73,NPOS2,BULTN,1280,NEXT)
CALL WXAI19(CRCRLF,3,BULTN,1280,NEXT)
ENDIF
C
C...BULLETIN HDGS FOR ONE BULTN COMPLETE IN O/P AREA
C
C***********************************************************************
C
C...CONTINUE BULTN, INSERTING DATA LINES.
C
NPOS1 = 5
LINE73(1:73) = SPCS(1:73)
LINE73(1:1) = '$'
LINE73( 2: 5) = STNID(S)(1:4)
DO 5300 M = LMTLWR(J), LMTUPR(J)
IF (M.EQ.8 .AND. J.NE.3) CYCLE
NPOS1 = NPOS1 + 1
NPOS2 = NPOS1 + 4
LINE73(NPOS1:NPOS2) = IWIND(S,M)(1:4)
NPOS1 = NPOS1 + 4
IF (J.LE.2) THEN
IF ((M.GT.4).AND.(M.LE.10))THEN
NPOS2 = NPOS1 + 2
LINE73(NPOS1:NPOS2) = ITEMP(S,M)(1:3)
NPOS1 = NPOS1 + 3
ENDIF
ELSE IF (J.EQ.3) THEN
IF ((M.GT.4).AND.(M.LE.10))THEN
NPOS2 = NPOS1 + 2
LINE73(NPOS1:NPOS2) = ITEMP(S,M)(1:3)
NPOS1 = NPOS1 + 3
END IF
ELSE IF (J.GT.3) THEN
IF (M.EQ.10)THEN
NPOS2 = NPOS1 + 2
LINE73(NPOS1:NPOS2) = ITEMP(S,M)(1:3)
NPOS1 = NPOS1 + 3
END IF
END IF
IF (M.GT.10) THEN
NPOS2 = NPOS1 + 1
LINE73(NPOS1:NPOS2) = ITEMP(S,M)(2:3)
NPOS1 = NPOS1 + 2
END IF
5300 CONTINUE
C PRINT *,(LINE73(II:II),II=2,NPOS2)
C...NXTSAV HOLDS BYTE COUNT IN O/P BULTN FOR RESTORING WXAI19 'NEXT'
C... FIELD SO THAT WHEN 'NEXT' IS RETURNED AS -1, AN ADDITIONAL
C... LINEFEED AND/OR ETB OR ETX CAN BE INSERTED
C
IF (NEXT.GE.1207) THEN
CALL WXAI19 (ETB,1,BULTN,1280,NEXT)
LF = CHAR(10)
do ii=1,next
space(index) = bultn(ii)
if (index .eq. 1280) then
WRITE(51,REC=IREC) space, LF
IREC=IREC + 1
index = 0
endif
index = index + 1
enddo
2103 format(1x,40z2)
2104 format(1x,80a1)
C WRITE(51) BULTN, LF
NEXT = 0
ENDIF
CALL WXAI19(LINE73,NPOS2,BULTN,1280,NEXT)
CALL WXAI19(CRCRLF,3,BULTN,1280,NEXT)
C
C...AFTER LINE STORED IN O/P, GO TO CHECK BULTN END
C
C...................................
C
C...CHECK FOR LAST STN OF BULTN
IF (ICK(1:1).NE.BEND(1:1)) GO TO 4150
C
C...END BULLETIN. SET UP RETURN FOR NEXT STN AFTER WRITE O/P.
C...SAVE SEQ NR OF LAST STN FOR SUBSEQUENT SEARCH FOR STNS
C
NXTSAV = NEXT
ENDBUL = .TRUE.
C***********************************************************************
C
C...OUTPUT SECTION
C
NEXT = NXTSAV
ETBETX = ETB
IF (ENDBUL) ETBETX=ETX
C...END OF TRANSMIT BLOCK, OR END OF TRANSMISSION
C
CALL WXAI19(ETBETX,1,BULTN,1280,NEXT)
C
C...OUTPUT TO HOLD FILES
LF = CHAR(10)
do ii=1,next
space(index) = bultn(ii)
if (index .eq. 1280) then
WRITE(51,REC=IREC) space, LF
IREC=IREC + 1
index = 0
endif
index = index + 1
enddo
C
C...TRAN.
C
NEXT=0
ENDBUL=.FALSE.
C
C...RETURN TO START NEW BULTN, OR CONTINUE LINE FOR WHICH THERE WAS
C... INSUFFICIENT SPACE IN BLOCK JUST WRITTEN
C
6900 CONTINUE
C
C***********************************************************************
7000 CONTINUE
C...END TAU LOOP
C
C...FT51 IS TRANSMISSION FILE
C END FILE 51
C REWIND 51
if (index .gt. 0) then
WRITE(51,REC=IREC) space, LF
IREC=IREC+1
endif
KRET = 0
CALL W3TAGE('BULLS_FDWNDTRX')
STOP
END
SUBROUTINE WXAI19(LINE, L, NBLK, N, NEXT)
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: WXAI19 LINE BLOCKER SUBROUTINE
C AUTHOR: ALLARD, R. ORG: W342 DATE: 01 FEB 74
C
C ABSTRACT: FILLS A RECORD BLOCK WITH LOGICAL RECORDS OR LINES
C OF INFORMATION.
C
C PROGRAM HISTORY LOG:
C 74-02-01 BOB ALLARD
C 90-09-15 R.E.JONES CONVERT FROM IBM370 ASSEMBLER TO MICROSOFT
C FORTRAN 5.0
C 90-10-07 R.E.JONES CONVERT TO SUN FORTRAN 1.3
C 91-07-20 R.E.JONES CONVERT TO SiliconGraphics 3.3 FORTRAN 77
C 93-03-29 R.E.JONES ADD SAVE STATEMENT
C 94-04-22 R.E.JONES ADD XMOVEX AND XSTORE TO MOVE AND
C STORE CHARACTER DATA FASTER ON THE CRAY
C 96-07-18 R.E.JONES CHANGE EBCDIC FILL TO ASCII FILL
C 96-11-18 R.E.JONES CHANGE NAME W3AI19 TO WXAI19
C
C USAGE: CALL WXAI19 (LINE, L, NBLK, N, NEXT)
C INPUT ARGUMENT LIST:
C LINE - ARRAY ADDRESS OF LOGICAL RECORD TO BE BLOCKED
C L - NUMBER OF CHARACTERS IN LINE TO BE BLOCKED
C N - MAXIMUM CHARACTER SIZE OF NBLK
C NEXT - FLAG, INITIALIZED TO 0
C
C OUTPUT ARGUMENT LIST:
C NBLK - BLOCK FILLED WITH LOGICAL RECORDS
C NEXT - CHARACTER COUNT, ERROR INDICATOR
C
C EXIT STATES:
C NEXT = -1 LINE WILL NOT FIT INTO REMAINDER OF BLOCK;
C OTHERWISE, NEXT IS SET TO (NEXT + L)
C NEXT = -2 N IS ZERO OR LESS
C NEXT = -3 L IS ZERO OR LESS
C
C EXTERNAL REFERENCES: XMOVEX XSTORE
C
C ATTRIBUTES:
C LANGUAGE: FORTRAN 90
C
C$$$
C
C METHOD:
C
C THE USER MUST SET NEXT = 0 EACH TIME NBLK IS TO BE FILLED WITH
C LOGICAL RECORDS.
C
C WXAI19 WILL THEN MOVE THE LINE OF INFORMATION INTO NBLK, STORE
C BLANK CHARACTERS IN THE REMAINDER OF THE BLOCK, AND SET NEXT = NEXT
C + L.
C
C EACH TIME WXAI19 IS ENTERED, ONE LINE IS BLOCKED AND NEXT INCRE-
C MENTED UNTIL A LINE WILL NOT FIT THE REMAINDER OF THE BLOCK. THEN
C WXAI19 WILL SET NEXT = -1 AS A FLAG FOR THE USER TO DISPOSE OF THE
C BLOCK. THE USER SHOULD BE AWARE THAT THE LAST LOGICAL RECORD WAS NOT
C BLOCKED.
C
INTEGER L
INTEGER N
INTEGER NEXT
INTEGER WBLANK
C
CHARACTER * 1 LINE(*)
CHARACTER * 1 NBLK(*)
CHARACTER * 1 BLANK
C
SAVE
C
DATA WBLANK/Z'2020202020202020'/
C DATA WBLANK/Z''/
C
C TEST VALUE OF NEXT.
C
IF (NEXT.LT.0) THEN
RETURN
C
C TEST N FOR ZERO OR LESS
C
ELSE IF (N.LE.0) THEN
NEXT = -2
RETURN
C
C TEST L FOR ZERO OR LESS
C
ELSE IF (L.LE.0) THEN
NEXT = -3
RETURN
C
C TEST TO SEE IF LINE WILL FIT IN BLOCK.
C
ELSE IF ((L + NEXT).GT.N) THEN
NEXT = -1
RETURN
C
C FILL BLOCK WITH BLANK CHARACTERS IF NEXT EQUAL ZERO.
C BLANK IS ASCII BLANK, 20 HEX, OR 32 DECIMAL
C
ELSE IF (NEXT.EQ.0) THEN
CALL W3FI01(LW)
IWORDS = N / LW
CALL XSTORE(NBLK,WBLANK,IWORDS)
IF (MOD(N,LW).NE.0) THEN
NWORDS = IWORDS * LW
IBYTES = N - NWORDS
DO I = 1,IBYTES
NBLK(NWORDS+I) = CHAR(32)
END DO
END IF
END IF
C
C MOVE LINE INTO BLOCK.
C
CALL XMOVEX(NBLK(NEXT+1),LINE,L)
C
C ADJUST VALUE OF NEXT.
C
NEXT = NEXT + L
C
RETURN
C
END