C************************************************************************ C* JWBUFR * C* * C* The routines in this module are a modified subset of Jack Woollen's * C* BUFR encoder/decoder. They are used to read (sequentially) a Jack * C* Woollen type BUFR file whose first message is a table of information * C* about the file contents. The routines and functions included here * C* are being treated temporarily as a "black box" for use by program * C* NAMSND. They will be upgraded and/or recoded to GEMPAK standards in * C* the near future. * C* * C** * C* Log: * C* J. Woollen 11/98 * C* D. Kidwell/NCEP 11/98 Simplified; replaced input with cbf_ calls * C* D. Kidwell/NCEP 12/98 Corrected function I4DY; SNMODL -> NAMSND * C* T. Lee/GSC 12/98 Changed VAL$ to VALS for LINUX * C* D. Kidwell/NCEP 1/99 Fixes to insure that argument types agree; * C* LINUX mods for reverse byte order; removed * C* ebcdic check and translation * C************************************************************************ C* C---------------------------------------------------------------------- C CONVERT AN INTEGER DESCRIPTOR TO FIVE OR SIX CHARACTER ASCII FORMAT C---------------------------------------------------------------------- FUNCTION ADN30(IDN,L30) COMMON /HRDWRD/ NBYTW,NBITW,NREV,IORD(8) CHARACTER*(*) ADN30 C---------------------------------------------------------------------- C---------------------------------------------------------------------- IF(LEN(ADN30).LT.L30 ) GOTO 900 IF(IDN.LT.0 .OR. IDN.GT.65535) GOTO 901 IF(L30.EQ.5) THEN WRITE(ADN30,'(I5)') IDN ELSEIF(L30.EQ.6) THEN IDF = ISHFT(IDN,-14) IDX = ISHFT(ISHFT(IDN,NBITW-14),-(NBITW-6)) IDY = ISHFT(ISHFT(IDN,NBITW- 8),-(NBITW-8)) WRITE(ADN30,'(I1,I2,I3)') IDF,IDX,IDY ELSE GOTO 902 ENDIF DO I=1,L30 IF(ADN30(I:I).EQ.' ') ADN30(I:I) = '0' ENDDO RETURN 900 CALL BORT('ADN30 - FUNCTION RETURN STRING TOO SHORT') 901 CALL BORT('ADN30 - IDN OUT OF RANGE ') 902 CALL BORT('ADN30 - CHARACTER LENGTH L30 <> 5 OR 6') END C----------------------------------------------------------------------- C----------------------------------------------------------------------- SUBROUTINE BFRINI COMMON /BITBUF/ MAXBYT,IBIT,IBAY(3000),MBYT(10),MBAY(3000,10) COMMON /PADESC/ IBCT,IPD1,IPD2,IPD3,IPD4 COMMON /REPTAB/ IDNR(5,2),TYPS(5,2),REPS(5,2),LENS(5) COMMON /STBFR / IOLUN(10),IOMSG(10) COMMON /TABABD/ NTBA(0:10),NTBB(0:10),NTBD(0:10),MTAB(50,10), . IDNA(50,10,2),IDNB(250,10),IDND(250,10), . TABA(50,10),TABB(250,10),TABD(250,10) COMMON /DXTAB / MAXDX,IDXV,NXSTR(10),LDXA(10),LDXB(10),LDXD(10), . LD30(10),DXSTR(10) COMMON /TABLES/ MAXTAB,NTAB,TAG(15000),TYP(15000),KNT(15000), . JUMP(15000),LINK(15000),JMPB(15000), . IBT(15000),IRF(15000),ISC(15000), . ITP(15000),VALI(15000),KNTI(15000), . ISEQ(15000,2),JSEQ(15000) COMMON /BUFRMG/ MSGLEN,MSGTXT(3000) COMMON /MRGCOM/ NRPL,NMRG,NAMB,NTOT COMMON /DATELN/ LENDAT COMMON /QUIET / IPRT common /ACMODE/ iac CHARACTER*600 TABD CHARACTER*128 TABB CHARACTER*128 TABA CHARACTER*56 DXSTR CHARACTER*10 TAG CHARACTER*6 ADSN(5,2),DNDX(25,10) CHARACTER*3 TYPX(5,2),TYPS,TYP CHARACTER*1 REPX(5,2),REPS DIMENSION NDNDX(10),NLDXA(10),NLDXB(10),NLDXD(10),NLD30(10) DIMENSION LENX(5) DATA ADSN / '101000','360001','360002','360003','360004' , . '101255','031002','031001','031001','031000' / DATA TYPX / 'REP', 'DRP', 'DRP', 'DRS' , 'DRB' , . 'SEQ', 'RPC', 'RPC', 'RPS' , 'SEQ' / DATA REPX / '"', '(', '{', '[' , '<' , . '"', ')', '}', ']' , '>' / DATA LENX / 0 , 16 , 8 , 8 , 1 / DATA (DNDX(I,1),I=1,25)/ .'102000','031001','000001','000002', .'110000','031001','000010','000011','000012','000013','000015', . '000016','000017','000018','000019','000020', .'107000','031001','000010','000011','000012','000013','101000', . '031001','000030'/ DATA (DNDX(I,2),I=1,15)/ .'103000','031001','000001','000002','000003', .'101000','031001','300004', .'105000','031001','300003','205064','101000','031001','000030'/ DATA NDNDX / 25 , 15 , 8*0 / DATA NLDXA / 35 , 67 , 8*0 / DATA NLDXB / 80 , 112 , 8*0 / DATA NLDXD / 38 , 70 , 8*0 / DATA NLD30 / 5 , 6 , 8*0 / C----------------------------------------------------------------------- C----------------------------------------------------------------------- C INITIALIZE /BITBUF/ C ------------------- MAXBYT = 9970 C INITIALIZE /PADESC/ C ------------------- IBCT = IFXY('063000') IPD1 = IFXY('102000') IPD2 = IFXY('031001') IPD3 = IFXY('206001') IPD4 = IFXY('063255') C INITIALIZE /STBFR/ C ------------------ DO I=1,10 IOLUN(I) = 0 IOMSG(I) = 0 ENDDO C INITIALIZE /REPTAB/ C ------------------- DO I=1,5 LENS(I) = LENX(I) DO J=1,2 IDNR(I,J) = IFXY(ADSN(I,J)) TYPS(I,J) = TYPX(I,J) REPS(I,J) = REPX(I,J) ENDDO ENDDO C INITIALIZE /TABABD/ C ------------------- NTBA(0) = 50 NTBB(0) = 250 NTBD(0) = 250 C INITIALIZE /DXTAB/ C ------------------ MAXDX = MAXBYT IDXV = 1 DO J=1,10 LDXA(J) = NLDXA(J) LDXB(J) = NLDXB(J) LDXD(J) = NLDXD(J) LD30(J) = NLD30(J) DXSTR(J) = ' ' NXSTR(J) = NDNDX(J)*2 DO I=1,NDNDX(J) I1 = I*2-1 itmp = IFXY ( dndx ( i, j ) ) CALL MV_ITOB ( itmp, i1-1, 2, dxstr(j), iret ) ENDDO ENDDO C INITIALIZE /TABLES/ C ------------------- MAXTAB = 15000 C INITIALIZE /BUFRMG/ C ------------------- MSGLEN = 0 C INITIALIZE /MRGCOM/ C ------------------- NRPL = 0 NMRG = 0 NAMB = 0 NTOT = 0 C INITIALIZE /DATELN/ C ------------------- IF(LENDAT.NE.10) LENDAT = 8 C INITIALIZE /QUIET/ C ------------------ IPRT = 0 C INITIALIZE /ACMODE/ C ------------------ IAC = 0 RETURN END C---------------------------------------------------------------------- C ENTRY POINT BORT IS REQUIRED FOR NON-CRAY SYSTEMS C---------------------------------------------------------------------- SUBROUTINE BORT(STR) CHARACTER*(*) STR PRINT* PRINT*,'************************ABORT**************************' PRINT*,STR PRINT*,'************************ABORT**************************' PRINT* CALLEXIT(49) END C----------------------------------------------------------------------- C----------------------------------------------------------------------- SUBROUTINE CHEKSTAB(LUN) COMMON /TABABD/ NTBA(0:10),NTBB(0:10),NTBD(0:10),MTAB(50,10), . IDNA(50,10,2),IDNB(250,10),IDND(250,10), . TABA(50,10),TABB(250,10),TABD(250,10) CHARACTER*600 TABD CHARACTER*128 TABB CHARACTER*128 TABA CHARACTER*24 UNIT CHARACTER*8 NEMO,NEMS(250) CHARACTER*1 TAB DIMENSION IRPS(250),KNTS(250) C----------------------------------------------------------------------- C----------------------------------------------------------------------- C THERE MUST BE ENTRIES IN TABLES A, B, AND D C ------------------------------------------- IF(NTBA(LUN).EQ.0) GOTO 900 IF(NTBB(LUN).EQ.0) GOTO 901 IF(NTBD(LUN).EQ.0) GOTO 902 C MAKE SURE EACH TABLE A ENTRY DEFINED AS A SEQUENCE C -------------------------------------------------- DO I=1,NTBA(LUN) NEMO = TABA(I,LUN)(4:11) CALL NEMTAB(LUN,NEMO,IDN,TAB,IRET) IF(TAB.NE.'D') GOTO 903 ENDDO C CHECK TABLE B CONTENTS C ---------------------- DO ITAB=1,NTBB(LUN) CALL NEMTBB(LUN,ITAB,UNIT,ISCL,IREF,IBIT) ENDDO C CHECK TABLE D CONTNETS C ---------------------- DO ITAB=1,NTBD(LUN) CALL NEMTBD(LUN,ITAB,NSEQ,NEMS,IRPS,KNTS) ENDDO RETURN 900 CALL BORT('CHEKSTAB - EMPTY TABLE A') 901 CALL BORT('CHEKSTAB - EMPTY TABLE B') 902 CALL BORT('CHEKSTAB - EMPTY TABLE D') 903 CALL BORT('CHEKSTAB - NO SEQUENCE DEFINED FOR TABLE A: '//NEMO) END C---------------------------------------------------------------------- C CHARACTER TRANSFER TO A STRING C---------------------------------------------------------------------- SUBROUTINE CHRTRN(STR,CHR,N) CHARACTER*(*) STR CHARACTER*1 CHR(N) C---------------------------------------------------------------------- C---------------------------------------------------------------------- DO I=1,N STR(I:I) = CHR(I) ENDDO RETURN END C----------------------------------------------------------------------- C----------------------------------------------------------------------- SUBROUTINE CLOSBF(LUNIT) CALL STATUS(LUNIT,LUN,IL,IM) IF(IL.GT.0 .AND. IM.NE.0) CALL CLOSMG(LUNIT) CALL WTSTAT(LUNIT,LUN,0,0) CALL CBF_CLOS ( ier ) RETURN END C----------------------------------------------------------------------- C----------------------------------------------------------------------- SUBROUTINE CLOSMG(LUNIT) COMMON /BITBUF/ MAXBYT,IBIT,IBAY(3000),MBYT(10),MBAY(3000,10) C----------------------------------------------------------------------- C----------------------------------------------------------------------- CALL STATUS(LUNIT,LUN,IL,IM) IF(IL.EQ.0) GOTO 900 IF(IL.LT.0) GOTO 901 IF(IM.NE.0) GO TO 902 CALL WTSTAT(LUNIT,LUN,IL,0) RETURN 900 CALL BORT('CLOSMG - FILE IS CLOSED ') 901 CALL BORT('CLOSMG - FILE IS OPEN FOR INPUT ') 902 CALL BORT('CLOSMG - WARNING - Need MSGWRT call') END C---------------------------------------------------------------------- C---------------------------------------------------------------------- SUBROUTINE CONWIN(LUN,INC1,INC2,NBMP) COMMON /USRINT/ NVAL(10),INV(15000,10),VAL(15000,10) COMMON /USRSTR/ NNOD,NCON,NODS(20),NODC(10),IVLS(10),KONS(10) REAL*8 VAL C---------------------------------------------------------------------- C---------------------------------------------------------------------- C SPECIAL CASES C ------------- IF(NCON.EQ.0) THEN INC1 = 1 INC2 = NVAL(LUN) RETURN ENDIF IF(INC1.GT.1 .AND. KONS(NCON).EQ.5) THEN CALL NXTWIN(LUN,INC1,INC2) RETURN ENDIF C EVALUATE CONDITIONS TO SEE IF ANY MORE CASES C -------------------------------------------- 10 DO NC=1,NCON IF(KONS(NC).EQ.5) THEN INC1 = INVWIN(NODC(NC),LUN,INC1,NVAL(LUN)) CALL USRTPL(LUN,INC1-1,NBMP) CALL NEWWIN(LUN,INC1,INC2) ELSE 15 CALL GETWIN(NODC(NC),LUN,INC1,INC2) IF(INC1.EQ.0 .AND. NC.EQ.1) RETURN IF(INC1.EQ.0 ) GOTO10 ICON = INVCON(NC,LUN,INC1,INC2) IF(ICON.EQ.0) GOTO 15 ENDIF ENDDO RETURN END C----------------------------------------------------------------------- C----------------------------------------------------------------------- LOGICAL FUNCTION DIGIT(STR) CHARACTER*(*) STR DIGIT = .FALSE. DO I=1,LEN(STR) IF(STR(I:I).NE.'0' .AND. STR(I:I).NE.'1' .AND. . STR(I:I).NE.'2' .AND. STR(I:I).NE.'3' .AND. . STR(I:I).NE.'4' .AND. STR(I:I).NE.'5' .AND. . STR(I:I).NE.'6' .AND. STR(I:I).NE.'7' .AND. . STR(I:I).NE.'8' .AND. STR(I:I).NE.'9') RETURN ENDDO DIGIT = .TRUE. RETURN END C----------------------------------------------------------------------- C----------------------------------------------------------------------- SUBROUTINE DRSTPL(INOD,LUN,INV1,INV2,INVN) COMMON /TABLES/ MAXTAB,NTAB,TAG(15000),TYP(15000),KNT(15000), . JUMP(15000),LINK(15000),JMPB(15000), . IBT(15000),IRF(15000),ISC(15000), . ITP(15000),VALI(15000),KNTI(15000), . ISEQ(15000,2),JSEQ(15000) COMMON /USRINT/ NVAL(10),INV(15000,10),VAL(15000,10) CHARACTER*10 TAG CHARACTER*3 TYP REAL*8 VAL C----------------------------------------------------------------------- CFPP$ EXPAND (INVWIN,USRTPL,NEWWIN) C----------------------------------------------------------------------- 1 NODE = INOD 2 NODE = JMPB(NODE) IF(NODE.EQ.0) RETURN IF(TYP(NODE).EQ.'DRS' .OR. TYP(NODE).EQ.'DRB') THEN INVN = INVWIN(NODE,LUN,INV1,INV2) IF(INVN.GT.0) THEN CALL USRTPL(LUN,INVN,1) CALL NEWWIN(LUN,INV1,INV2) INVN = INVWIN(INOD,LUN,INVN,INV2) IF(INVN.GT.0) RETURN GOTO 1 ENDIF ENDIF GOTO 2 900 CALL BORT('DRSTPL - CANT FIND NODE:'//TAG(INOD)) END C----------------------------------------------------------------------- C----------------------------------------------------------------------- SUBROUTINE DXINIT(LUN,IOI) COMMON /PADESC/ IBCT,IPD1,IPD2,IPD3,IPD4 COMMON /REPTAB/ IDNR(5,2),TYPS(5,2),REPS(5,2),LENS(5) COMMON /MSGCWD/ NMSG(10),NSUB(10),MSUB(10),INODE(10),IDATE(10) COMMON /TABABD/ NTBA(0:10),NTBB(0:10),NTBD(0:10),MTAB(50,10), . IDNA(50,10,2),IDNB(250,10),IDND(250,10), . TABA(50,10),TABB(250,10),TABD(250,10) CHARACTER*600 TABD CHARACTER*128 TABB CHARACTER*128 TABA CHARACTER*8 INIB(6,5),INID(5) CHARACTER*6 ADN30 CHARACTER*3 TYPS CHARACTER*1 REPS DATA INIB /'------','BYTCNT ','BYTES ','+0','+0','16', . '------','BITPAD ','NONE ','+0','+0','1 ', . '031000','DRF1BIT ','NUMERIC','+0','+0','1 ', . '031001','DRF8BIT ','NUMERIC','+0','+0','8 ', . '031002','DRF16BIT','NUMERIC','+0','+0','16'/ DATA NINIB /5/ DATA INID /' ', . 'DRP16BIT', . 'DRP8BIT ', . 'DRPSTAK ', . 'DRP1BIT '/ DATA NINID /5/ C----------------------------------------------------------------------- C----------------------------------------------------------------------- C CLEAR OUT A MESSAGE CONTROL WORD PARTITION C ------------------------------------------ NMSG(LUN) = 0 NSUB(LUN) = 0 MSUB(LUN) = 0 INODE(LUN) = 0 IDATE(LUN) = 0 C CLEAR OUT A TABLE PARTITION C --------------------------- NTBA(LUN) = 0 DO I=1,NTBA(0) TABA(I,LUN) = ' ' MTAB(I,LUN) = 0 ENDDO NTBB(LUN) = 0 DO I=1,NTBB(0) TABB(I,LUN) = ' ' ENDDO NTBD(LUN) = 0 DO I=1,NTBD(0) TABD(I,LUN) = ' ' CALL PKTDD(I,LUN,0,IRET) ENDDO IF(IOI.EQ.0) RETURN C INITIALIZE TABLE WITH APRIORI TABLE B AND D ENTRIES C --------------------------------------------------- INIB(1,1) = ADN30(IBCT,6) INIB(1,2) = ADN30(IPD4,6) DO I=1,NINIB NTBB(LUN) = NTBB(LUN)+1 IDNB(I,LUN) = IFXY(INIB(1,I)) TABB(I,LUN)( 1: 6) = INIB(1,I) TABB(I,LUN)( 7: 70) = INIB(2,I) TABB(I,LUN)( 71: 94) = INIB(3,I) TABB(I,LUN)( 95: 98) = INIB(4,I) TABB(I,LUN)( 99:109) = INIB(5,I) TABB(I,LUN)(110:112) = INIB(6,I) ENDDO DO I=2,NINID N = NTBD(LUN)+1 IDND(N,LUN) = IDNR(I,1) TABD(N,LUN)(1: 6) = ADN30(IDNR(I,1),6) TABD(N,LUN)(7:70) = INID(I) CALL PKTDD(N,LUN,IDNR(1,1),IRET) CALL PKTDD(N,LUN,IDNR(I,2),IRET) NTBD(LUN) = N ENDDO RETURN END SUBROUTINE GETABDB(LUNIT,TABDB,ITAB,JTAB) COMMON /TABABD/ NTBA(0:10),NTBB(0:10),NTBD(0:10),MTAB(50,10), . IDNA(50,10,2),IDNB(250,10),IDND(250,10), . TABA(50,10),TABB(250,10),TABD(250,10) CHARACTER*600 TABD CHARACTER*128 TABB CHARACTER*128 TABA CHARACTER*128 TABDB(ITAB) CHARACTER*8 NEMO,NEMS(250) DIMENSION IRPS(250),KNTS(250) C----------------------------------------------------------------------- C----------------------------------------------------------------------- JTAB = 0 C MAKE SURE THE FILE IS OPEN C -------------------------- CALL STATUS(LUNIT,LUN,IL,IM) IF(IL.EQ.0) RETURN C WRITE OUT THE TABLE D ENTRIES FOR THIS FILE C ------------------------------------------- DO I=1,NTBD(LUN) NEMO = TABD(I,LUN)(7:14) CALL NEMTBD(LUN,I,NSEQ,NEMS,IRPS,KNTS) DO J=1,NSEQ,10 JTAB = JTAB+1 IF(JTAB.LE.ITAB) THEN WRITE(TABDB(JTAB),1) NEMO,(NEMS(K),K=J,MIN(J+9,NSEQ)) 1 FORMAT('D ',A8,10(1X,A10)) ENDIF ENDDO ENDDO C ADD THE TABLE B ENTRIES C ----------------------- DO I=1,NTBB(LUN) JTAB = JTAB+1 IF(JTAB.LE.ITAB) THEN WRITE(TABDB(JTAB),2) TABB(I,LUN)(7:14),TABB(I,LUN)(71:112) 2 FORMAT('B ',A8,1X,A42) ENDIF ENDDO RETURN END C---------------------------------------------------------------------- C---------------------------------------------------------------------- SUBROUTINE GETWIN(NODE,LUN,IWIN,JWIN) COMMON /USRINT/ NVAL(10),INV(15000,10),VAL(15000,10) REAL*8 VAL C---------------------------------------------------------------------- cfpp$ expand (lstrpc) C---------------------------------------------------------------------- IRPC = LSTRPC(NODE,LUN) IF(IRPC.EQ.0) THEN IWIN = INVWIN(NODE,LUN,JWIN,NVAL(LUN)) IF(IWIN.EQ.0 .and. jwin.gt.1) RETURN IWIN = 1 JWIN = NVAL(LUN) RETURN ELSE IWIN = INVWIN(IRPC,LUN,JWIN,NVAL(LUN)) IF(IWIN.EQ.0) THEN RETURN ELSEIF(VAL(IWIN,LUN).EQ.0.) THEN IWIN = 0 RETURN ENDIF ENDIF JWIN = INVWIN(IRPC,LUN,IWIN+1,NVAL(LUN)) IF(JWIN.EQ.0) CALL BORT('GETWIN - MISSING BRACKET') RETURN END C---------------------------------------------------------------------- C CONVERT AN 8 DIGIT INTEGER DATE (YYMMDDHH) TO 10 DIGITS (CCYYMMDDHH) C---------------------------------------------------------------------- FUNCTION I4DY(IDATE) IF(IDATE.LT.10**8) THEN IY = IDATE/10**6 IF(IY.GT.20) I4DY = IDATE + 19*10**8 IF(IY.LE.20) I4DY = IDATE + 20*10**8 ELSE I4DY = IDATE ENDIF RETURN END C---------------------------------------------------------------------- C CONVERT A FIVE OR SIX CHARACTER ASCII DESCRIPTOR TO AN INTEGER C---------------------------------------------------------------------- FUNCTION IDN30(ADN30,L30) COMMON /HRDWRD/ NBYTW,NBITW,NREV,IORD(8) CHARACTER*(*) ADN30 C---------------------------------------------------------------------- C---------------------------------------------------------------------- IF(LEN(ADN30).LT.L30) GOTO 900 IF(L30.EQ.5) THEN READ(ADN30,'(I5)') IDN30 IF(IDN30.LT.0 .OR. IDN30.GT.65535) GOTO 901 ELSEIF(L30.EQ.6) THEN IDN30 = IFXY(ADN30) ELSE GOTO 902 ENDIF RETURN 900 CALL BORT('IDN30 - FUNCTION INPUT STRING TOO SHORT ') 901 CALL BORT('IDN30 - IDN OUT OF RANGE, NOT A DESCRIPTOR ') 902 CALL BORT('IDN30 - CHARACTER LENGTH L30 <> 5 OR 6 ') END C---------------------------------------------------------------------- C CONVERT A SIX CHARACTER (FXY) ASCII DESCRIPTOR TO AN INTEGER C---------------------------------------------------------------------- FUNCTION IFXY(ADSC) CHARACTER*6 ADSC C---------------------------------------------------------------------- C---------------------------------------------------------------------- READ(ADSC,'(I1,I2,I3)') IF,IX,IY IFXY = IF*2**14 + IX*2**8 + IY RETURN END C----------------------------------------------------------------------- C----------------------------------------------------------------------- SUBROUTINE INCTAB(ATAG,ATYP,NODE) COMMON /TABLES/ MAXTAB,NTAB,TAG(15000),TYP(15000),KNT(15000), . JUMP(15000),LINK(15000),JMPB(15000), . IBT(15000),IRF(15000),ISC(15000), . ITP(15000),VALI(15000),KNTI(15000), . ISEQ(15000,2),JSEQ(15000) CHARACTER*(*) ATAG,ATYP CHARACTER*10 TAG CHARACTER*3 TYP C----------------------------------------------------------------------- C----------------------------------------------------------------------- NTAB = NTAB+1 IF(NTAB.GT.MAXTAB) CALL BORT('INCTAB - TOO MANY ENTRIES') TAG(NTAB) = ATAG TYP(NTAB) = ATYP NODE = NTAB RETURN END C---------------------------------------------------------------------- C---------------------------------------------------------------------- FUNCTION INVCON(NC,LUN,INV1,INV2) COMMON /USRINT/ NVAL(10),INV(15000,10),VAL(15000,10) COMMON /USRSTR/ NNOD,NCON,NODS(20),NODC(10),IVLS(10),KONS(10) REAL*8 VAL C---------------------------------------------------------------------- C---------------------------------------------------------------------- C CHECK THE INVENTORY INTERVAL C ---------------------------- IF(INV1.LE.0 .OR. INV1.GT.NVAL(LUN)) GOTO 99 IF(INV2.LE.0 .OR. INV2.GT.NVAL(LUN)) GOTO 99 C FIND AN OCCURANCE OF NODE IN THE WINDOW MEETING THIS CONDITION C -------------------------------------------------------------- DO INVCON=INV1,INV2 IF(INV(INVCON,LUN).EQ.NODC(NC)) THEN IF(KONS(NC).EQ.1 .AND. VAL(INVCON,LUN).EQ.IVLS(NC)) RETURN IF(KONS(NC).EQ.2 .AND. VAL(INVCON,LUN).NE.IVLS(NC)) RETURN IF(KONS(NC).EQ.3 .AND. VAL(INVCON,LUN).LT.IVLS(NC)) RETURN IF(KONS(NC).EQ.4 .AND. VAL(INVCON,LUN).GT.IVLS(NC)) RETURN ENDIF ENDDO 99 INVCON = 0 RETURN END C---------------------------------------------------------------------- C---------------------------------------------------------------------- FUNCTION INVWIN(NODE,LUN,INV1,INV2) COMMON /MSGCWD/ NMSG(10),NSUB(10),MSUB(10),INODE(10),IDATE(10) COMMON /TABLES/ MAXTAB,NTAB,TAG(15000),TYP(15000),KNT(15000), . JUMP(15000),LINK(15000),JMPB(15000), . IBT(15000),IRF(15000),ISC(15000), . ITP(15000),VALI(15000),KNTI(15000), . ISEQ(15000,2),JSEQ(15000) COMMON /USRINT/ NVAL(10),INV(15000,10),VAL(15000,10) CHARACTER*10 TAG CHARACTER*3 TYP REAL*8 VAL C---------------------------------------------------------------------- C---------------------------------------------------------------------- IF(NODE.EQ.0) RETURN C SEARCH BETWEEN INV1 AND INV2 C ---------------------------- 10 DO INVWIN=INV1,INV2 IF(INV(INVWIN,LUN).EQ.NODE) RETURN ENDDO INVWIN = 0 RETURN END C---------------------------------------------------------------------- C UNPACK UP AN INTEGER FROM A PACKED INTEGER ARRAY (FUNCTION) C---------------------------------------------------------------------- FUNCTION IUPB(MBAY,NBYT,NBIT) DIMENSION MBAY(*) C---------------------------------------------------------------------- C---------------------------------------------------------------------- MBIT = (NBYT-1)*8 CALL UPB(IRET,NBIT,MBAY,MBIT) IUPB = IRET RETURN END C---------------------------------------------------------------------- C---------------------------------------------------------------------- FUNCTION LSTJPB(NODE,LUN,JBTYP) COMMON /MSGCWD/ NMSG(10),NSUB(10),MSUB(10),INODE(10),IDATE(10) COMMON /TABLES/ MAXTAB,NTAB,TAG(15000),TYP(15000),KNT(15000), . JUMP(15000),LINK(15000),JMPB(15000), . IBT(15000),IRF(15000),ISC(15000), . ITP(15000),VALI(15000),KNTI(15000), . ISEQ(15000,2),JSEQ(15000) CHARACTER*(*) JBTYP CHARACTER*10 TAG CHARACTER*3 TYP C---------------------------------------------------------------------- C---------------------------------------------------------------------- C MAKE SURE WE ARE ALL ON THE SAME PAGE C ------------------------------------- IF(NODE.LT.INODE(LUN) .OR. NODE.GT.ISC(INODE(LUN))) THEN PRINT*,INODE(LUN),':',NODE,':',TAG(NODE) CALL BORT('LSTJPB - TABLE NODE IS OUT OF BOUNDS') ENDIF C FIND THIS OR THE PREVIOUS RPC NODE C ---------------------------------- LSTJPB = NODE 10 IF(TYP(LSTJPB).NE.JBTYP) THEN LSTJPB = JMPB(LSTJPB) IF(LSTJPB.NE.0) GOTO 10 ENDIF RETURN END C---------------------------------------------------------------------- C---------------------------------------------------------------------- FUNCTION LSTRPC(NODE,LUN) COMMON /MSGCWD/ NMSG(10),NSUB(10),MSUB(10),INODE(10),IDATE(10) COMMON /TABLES/ MAXTAB,NTAB,TAG(15000),TYP(15000),KNT(15000), . JUMP(15000),LINK(15000),JMPB(15000), . IBT(15000),IRF(15000),ISC(15000), . ITP(15000),VALI(15000),KNTI(15000), . ISEQ(15000,2),JSEQ(15000) CHARACTER*10 TAG CHARACTER*3 TYP C---------------------------------------------------------------------- C---------------------------------------------------------------------- IF(NODE.LT.INODE(LUN) .OR. NODE.GT.ISC(INODE(LUN))) GOTO 900 NOD = NODE C FIND THIS OR THE PREVIOUS RPC NODE C ---------------------------------- 10 IF(TYP(NOD).NE.'RPC') THEN NOD = JMPB(NOD) IF(NOD.NE.0) GOTO 10 ENDIF LSTRPC = NOD RETURN 900 PRINT*,INODE(LUN),':',NODE CALL BORT('LSTRPC - TABLE NODE IS OUT OF BOUNDS') END C---------------------------------------------------------------------- C---------------------------------------------------------------------- FUNCTION LSTRPS(NODE,LUN) COMMON /MSGCWD/ NMSG(10),NSUB(10),MSUB(10),INODE(10),IDATE(10) COMMON /TABLES/ MAXTAB,NTAB,TAG(15000),TYP(15000),KNT(15000), . JUMP(15000),LINK(15000),JMPB(15000), . IBT(15000),IRF(15000),ISC(15000), . ITP(15000),VALI(15000),KNTI(15000), . ISEQ(15000,2),JSEQ(15000) CHARACTER*10 TAG CHARACTER*3 TYP C---------------------------------------------------------------------- C---------------------------------------------------------------------- IF(NODE.LT.INODE(LUN) .OR. NODE.GT.ISC(INODE(LUN))) GOTO 900 NOD = NODE C FIND THIS OR THE PREVIOUS RPS NODE C ---------------------------------- 10 IF(TYP(NOD).NE.'RPS') THEN NOD = JMPB(NOD) IF(NOD.NE.0) GOTO 10 ENDIF LSTRPS = NOD RETURN 900 CALL BORT('LSTRPS - TABLE NODE IS OUT OF BOUNDS') END C----------------------------------------------------------------------- C----------------------------------------------------------------------- SUBROUTINE MAKESTAB COMMON /QUIET/ IPRT COMMON /STBFR/ IOLUN(10),IOMSG(10) COMMON /MSGCWD/ NMSG(10),NSUB(10),MSUB(10),INODE(10),IDATE(10) COMMON /USRINT/ NVAL(10),INV(15000,10),VAL(15000,10) COMMON /TABABD/ NTBA(0:10),NTBB(0:10),NTBD(0:10),MTAB(50,10), . IDNA(50,10,2),IDNB(250,10),IDND(250,10), . TABA(50,10),TABB(250,10),TABD(250,10) COMMON /TABLES/ MAXTAB,NTAB,TAG(15000),TYP(15000),KNT(15000), . JUMP(15000),LINK(15000),JMPB(15000), . IBT(15000),IRF(15000),ISC(15000), . ITP(15000),VALI(15000),KNTI(15000), . ISEQ(15000,2),JSEQ(15000) CHARACTER*600 TABD CHARACTER*128 TABB CHARACTER*128 TABA CHARACTER*10 TAG CHARACTER*8 NEMO CHARACTER*3 TYP DIMENSION LUS(10) LOGICAL EXPAND,PRTTAB REAL*8 VAL C----------------------------------------------------------------------- C----------------------------------------------------------------------- PRTTAB = IPRT.GE.2 C RESET POINTER TABLE AND STRING CACHE C ------------------------------------ NTAB = 0 CALL STRCLN C FIGURE OUT WHICH UNITS SHARE TABLES C ----------------------------------- DO LUN=1,10 LUS(LUN) = 0 IF(IOLUN(LUN).NE.0) THEN DO LUM=1,LUN-1 IF(MTAB(1,LUN).EQ.MTAB(1,LUM)) LUS(LUN) = LUM ENDDO ENDIF ENDDO C INITIALIZE JUMP-LINK TABLES WITH SUBSETS/SEQUENCES/ELEMENTS C ---------------------------------------------------------- DO LUN=1,10 IF(IOLUN(LUN).NE.0) THEN C RESET ANY EXISTING INVENTORY POINTERS C ------------------------------------- IF(IOMSG(LUN).NE.0) THEN IF(LUS(LUN).EQ.0) INC = (NTAB+1)-MTAB(1,LUN) IF(LUS(LUN).NE.0) INC = MTAB(1,LUS(LUN))-MTAB(1,LUN) DO N=1,NVAL(LUN) INV(N,LUN) = INV(N,LUN)+INC ENDDO ENDIF C CREATE NEW TABLE ENTRIES IF THIS UNIT DOESN'T SHARE EXISTING ONES C ----------------------------------------------------------------- IF(LUS(LUN).EQ.0) THEN CALL CHEKSTAB(LUN) DO ITBA=1,NTBA(LUN) INOD = NTAB+1 NEMO = TABA(ITBA,LUN)(4:11) CALL TABSUB(LUN,NEMO) MTAB(ITBA,LUN) = INOD ISC(INOD) = NTAB C DO N1=INOD,ISC(INOD)-1 C DO N2=N1+1,ISC(INOD) C IF(TAG(N1).EQ.TAG(N2)) GOTO 900 C ENDDO C ENDDO ENDDO ENDIF ENDIF ENDDO C STORE TYPES AND INITIAL VALUES AND COUNTS C ----------------------------------------- DO NODE=1,NTAB IF(TYP(NODE).EQ.'SUB') THEN VALI(NODE) = 0 KNTI(NODE) = 1 ITP (NODE) = 0 ELSEIF(TYP(NODE).EQ.'SEQ') THEN VALI(NODE) = 0 KNTI(NODE) = 1 ITP (NODE) = 0 ELSEIF(TYP(NODE).EQ.'RPC') THEN VALI(NODE) = 0 KNTI(NODE) = 0 ITP (NODE) = 0 ELSEIF(TYP(NODE).EQ.'RPS') THEN VALI(NODE) = 0 KNTI(NODE) = 0 ITP (NODE) = 0 ELSEIF(TYP(NODE).EQ.'REP') THEN VALI(NODE) = 10E10 KNTI(NODE) = IRF(NODE) ITP (NODE) = 0 ELSEIF(TYP(NODE).EQ.'DRS') THEN VALI(NODE) = 0 KNTI(NODE) = 1 ITP (NODE) = 1 ELSEIF(TYP(NODE).EQ.'DRP') THEN VALI(NODE) = 0 KNTI(NODE) = 1 ITP (NODE) = 1 ELSEIF(TYP(NODE).EQ.'DRB') THEN VALI(NODE) = 0 KNTI(NODE) = 0 ITP (NODE) = 1 ELSEIF(TYP(NODE).EQ.'NUM') THEN VALI(NODE) = 10E10 KNTI(NODE) = 1 ITP (NODE) = 2 ELSEIF(TYP(NODE).EQ.'CHR') THEN VALI(NODE) = 10E10 KNTI(NODE) = 1 ITP (NODE) = 3 ELSE GOTO 901 ENDIF ENDDO C SET UP EXPANSION SEGMENTS FOR TYPE 'SUB', 'DRP', AND 'DRS' NODES C ---------------------------------------------------------------- NEWN = 0 DO N=1,NTAB ISEQ(N,1) = 0 ISEQ(N,2) = 0 EXPAND = TYP(N).EQ.'SUB' .OR. TYP(N).EQ.'DRP' .OR. TYP(N).EQ.'DRS' . .OR. TYP(N).EQ.'REP' .OR. TYP(N).EQ.'DRB' IF(EXPAND) THEN ISEQ(N,1) = NEWN+1 NODA = N NODE = N+1 DO K=1,15000 KNT(K) = 0 ENDDO IF(TYP(NODA).EQ.'REP') KNT(NODE) = KNTI(NODA) IF(TYP(NODA).NE.'REP') KNT(NODE) = 1 1 NEWN = NEWN+1 IF(NEWN.GT.15000) GOTO 902 JSEQ(NEWN) = NODE KNT(NODE) = MAX(KNTI(NODE),KNT(NODE)) 2 IF(JUMP(NODE)*KNT(NODE).GT.0) THEN NODE = JUMP(NODE) GOTO 1 ELSE IF(LINK(NODE).GT.0) THEN NODE = LINK(NODE) GOTO 1 ELSE NODE = JMPB(NODE) IF(NODE.EQ.NODA) GOTO 3 IF(NODE.EQ.0 ) GOTO 903 KNT(NODE) = MAX(KNT(NODE)-1,0) GOTO 2 ENDIF 3 ISEQ(N,2) = NEWN ENDIF ENDDO C PRINT THE SEQUENCE TABLES C ------------------------ IF(PRTTAB) THEN PRINT* DO I=1,NTAB PRINT99,I, . TAG(I),TYP(I),JMPB(I),JUMP(I),LINK(I),IBT(I),IRF(I),ISC(I) ENDDO PRINT* 99 FORMAT(I5,2X,A10,A5,6I8) ENDIF RETURN 900 CALL BORT('MAKESTAB - DUP IN SUBSET: '//TAG(N1)//':'//NEMO) 901 CALL BORT('MAKESTAB - UNKNOWN TYPE : ' //TYP(NODE)) 902 CALL BORT('MAKESTAB - JSEQ OVERFLOW : ' //TAG(N )) 903 CALL BORT('MAKESTAB - FAILED TO CIRCULATE : ' //TAG(N )) END C----------------------------------------------------------------------- C----------------------------------------------------------------------- SUBROUTINE NEMTAB(LUN,NEMO,IDN,TAB,IRET) COMMON /TABABD/ NTBA(0:10),NTBB(0:10),NTBD(0:10),MTAB(50,10), . IDNA(50,10,2),IDNB(250,10),IDND(250,10), . TABA(50,10),TABB(250,10),TABD(250,10) CHARACTER*(*) NEMO CHARACTER*600 TABD CHARACTER*128 TABB CHARACTER*128 TABA CHARACTER*8 NEMT CHARACTER*1 TAB LOGICAL FOLVAL C----------------------------------------------------------------------- C----------------------------------------------------------------------- FOLVAL = NEMO(1:1).EQ.'.' IRET = 0 TAB = ' ' C LOOK FOR NEMO IN TABLE B C ------------------------ DO 1 I=1,NTBB(LUN) NEMT = TABB(I,LUN)(7:14) IF(NEMT.EQ.NEMO) THEN IDN = IDNB(I,LUN) TAB = 'B' IRET = I RETURN ELSEIF(FOLVAL.AND.NEMT(1:1).EQ.'.') THEN DO J=2,LEN(NEMT) IF(NEMT(J:J).NE.'.' .AND. NEMT(J:J).NE.NEMO(J:J)) GOTO 1 ENDDO IDN = IDNB(I,LUN) TAB = 'B' IRET = I RETURN ENDIF 1 ENDDO C DON'T LOOK IN TABLE D FOR FOLLOWING VALUE-MNEMONICS C --------------------------------------------------- IF(FOLVAL) RETURN C LOOK IN TABLE D IF WE GOT THIS FAR C ---------------------------------- DO I=1,NTBD(LUN) NEMT = TABD(I,LUN)(7:14) IF(NEMT.EQ.NEMO) THEN IDN = IDND(I,LUN) TAB = 'D' IRET = I RETURN ENDIF ENDDO RETURN END C----------------------------------------------------------------------- C----------------------------------------------------------------------- SUBROUTINE NEMTBA(LUN,NEMO,MTYP,MSBT,INOD) COMMON /TABABD/ NTBA(0:10),NTBB(0:10),NTBD(0:10),MTAB(50,10), . IDNA(50,10,2),IDNB(250,10),IDND(250,10), . TABA(50,10),TABB(250,10),TABD(250,10) CHARACTER*(*) NEMO CHARACTER*600 TABD CHARACTER*128 TABB CHARACTER*128 TABA CHARACTER*20 NEMT C----------------------------------------------------------------------- C----------------------------------------------------------------------- NEMT = NEMO IRET = 0 C LOOK FOR NEMO IN TABLE A C ------------------------ DO I=1,NTBA(LUN) IF(TABA(I,LUN)(4:11).EQ.NEMO) THEN MTYP = IDNA(I,LUN,1) MSBT = IDNA(I,LUN,2) INOD = MTAB(I,LUN) IF(MTYP.LT.0 .OR. MTYP.GT.255) GOTO 900 IF(MSBT.LT.0 .OR. MSBT.GT.255) GOTO 901 RETURN ENDIF ENDDO CALL BORT('NEMTBA - CANT FIND '//NEMT) 900 CALL BORT('NEMTBA - BAD MTYP '//NEMT) 901 CALL BORT('NEMTBA - BAD MSBT '//NEMT) END C----------------------------------------------------------------------- C----------------------------------------------------------------------- SUBROUTINE NEMTBB(LUN,ITAB,UNIT,ISCL,IREF,IBIT) COMMON /TABABD/ NTBA(0:10),NTBB(0:10),NTBD(0:10),MTAB(50,10), . IDNA(50,10,2),IDNB(250,10),IDND(250,10), . TABA(50,10),TABB(250,10),TABD(250,10) CHARACTER*600 TABD CHARACTER*128 TABB CHARACTER*128 TABA CHARACTER*24 UNIT CHARACTER*8 NEMO REAL*8 MXR C----------------------------------------------------------------------- C----------------------------------------------------------------------- MXR = 1E11-1 IF(ITAB.LE.0 .OR. ITAB.GT.NTBB(LUN)) GOTO 900 C PULL OUT TABLE B INFORMATION C ---------------------------- IDN = IDNB(ITAB,LUN) NEMO = TABB(ITAB,LUN)( 7:14) UNIT = TABB(ITAB,LUN)(71:94) ISCL = VALS(TABB(ITAB,LUN)( 95: 98)) IREF = VALS(TABB(ITAB,LUN)( 99:109)) IBIT = VALS(TABB(ITAB,LUN)(110:112)) C CHECK TABLE B CONTENTS C ---------------------- IF(IDN.LT.IFXY('000000')) GOTO 901 IF(IDN.GT.IFXY('063255')) GOTO 901 IF(ISCL.LT.-999 .OR. ISCL.GT.999) GOTO 902 IF(IREF.LE.-MXR .OR. IREF.GE.MXR) GOTO 903 IF(IBIT.LE.0) GOTO 904 IF(UNIT(1:5).NE.'CCITT' .AND. IBIT.GT.64 ) GOTO 904 IF(UNIT(1:5).EQ.'CCITT' .AND. MOD(IBIT,8).NE.0) GOTO 905 RETURN 900 CALL BORT('NEMTBB - ITAB NOT IN TABLE B' ) 901 CALL BORT('NEMTBB - BAD DESCRIPTOR VALUE: '//NEMO) 902 CALL BORT('NEMTBB - BAD SCALE VALUE : '//NEMO) 903 CALL BORT('NEMTBB - BAD REFERENCE VALUE : '//NEMO) 904 CALL BORT('NEMTBB - BAD BIT WIDTH : '//NEMO) 905 CALL BORT('NEMTBB - BAD CHAR BIT WIDTH : '//NEMO) END C----------------------------------------------------------------------- C----------------------------------------------------------------------- SUBROUTINE NEMTBD(LUN,ITAB,NSEQ,NEMS,IRPS,KNTS) COMMON /TABABD/ NTBA(0:10),NTBB(0:10),NTBD(0:10),MTAB(50,10), . IDNA(50,10,2),IDNB(250,10),IDND(250,10), . TABA(50,10),TABB(250,10),TABD(250,10) CHARACTER*600 TABD CHARACTER*128 TABB CHARACTER*128 TABA CHARACTER*8 NEMO,NEMS,NEMT,NEMF CHARACTER*1 TAB DIMENSION NEMS(250),IRPS(250),KNTS(250) LOGICAL REP C----------------------------------------------------------------------- C----------------------------------------------------------------------- IF(ITAB.LE.0 .OR. ITAB.GT.NTBD(LUN)) GOTO 900 REP = .FALSE. C CLEAR THE RETURN VALUES C ----------------------- NSEQ = 0 DO I=1,250 NEMS(I) = ' ' IRPS(I) = 0 KNTS(I) = 0 ENDDO C PARSE THE TABLE D ENTRY C ----------------------- NEMO = TABD(ITAB,LUN)(7:14) IDSC = IDND(ITAB,LUN) CALL UPTDD(ITAB,LUN,0,NDSC) IF(IDSC.LT.IFXY('300000')) GOTO 901 IF(IDSC.GT.IFXY('363255')) GOTO 901 C IF(NDSC.LE.0 ) GOTO 902 DO J=1,NDSC IF(NSEQ+1.GT.250) GOTO 903 CALL UPTDD(ITAB,LUN,J,IDSC) CALL NUMTAB(LUN,IDSC,NEMT,TAB,IRET) IF(TAB.EQ.'R') THEN IF(REP) GOTO 904 REP = .TRUE. IF(IRET.LT.0) THEN IRPS(NSEQ+1) = 1 KNTS(NSEQ+1) = ABS(IRET) ELSEIF(IRET.GT.0) THEN IRPS(NSEQ+1) = IRET ENDIF ELSEIF(TAB.EQ.'F') THEN IF(.NOT.REP) GOTO 904 IRPS(NSEQ+1) = IRET REP = .FALSE. ELSEIF(TAB.EQ.'D') THEN REP = .FALSE. NSEQ = NSEQ+1 NEMS(NSEQ) = NEMT ELSEIF(TAB.EQ.'B') THEN REP = .FALSE. NSEQ = NSEQ+1 IF(NEMT(1:1).EQ.'.') THEN CALL UPTDD(ITAB,LUN,J+1,IDSC) CALL NUMTAB(LUN,IDSC,NEMF,TAB,IRET) CALL RSVFVM(NEMT,NEMF) IF(TAB.NE.'B') GOTO 906 ENDIF NEMS(NSEQ) = NEMT ELSE GOTO 905 ENDIF ENDDO RETURN 900 CALL BORT('NEMTBD - ITAB NOT IN TABLE D ' ) 901 CALL BORT('NEMTBD - BAD DESCRIPTOR VALUE: ' //NEMO) 902 CALL BORT('NEMTBD - ZERO LENGTH SEQUENCE: ' //NEMO) 903 CALL BORT('NEMTBD - TOO MANY DESCRIPTORS IN SEQ: ' //NEMO) 904 CALL BORT('NEMTBD - REPLICATOR OUT OF ORDER IN SEQ: '//NEMO) 905 CALL BORT('NEMTBD - BAD DESCRIPTOR IN SEQUENCE: ' //NEMO) 906 CALL BORT('NEMTBD - FOLLOWING VALUE NOT FROM TABLEB:'//NEMF) END C----------------------------------------------------------------------- C----------------------------------------------------------------------- SUBROUTINE NENUCK(NEMO,NUMB,LUN) COMMON /TABABD/ NTBA(0:10),NTBB(0:10),NTBD(0:10),MTAB(50,10), . IDNA(50,10,2),IDNB(250,10),IDND(250,10), . TABA(50,10),TABB(250,10),TABD(250,10) CHARACTER*600 TABD CHARACTER*128 TABB CHARACTER*128 TABA CHARACTER*8 NEMO CHARACTER*6 NUMB C----------------------------------------------------------------------- C----------------------------------------------------------------------- C CHECK TABLE A C ------------- ENTRY NENUAA(NEMO,NUMB,LUN) DO N=1,NTBA(LUN) IF(NUMB(4:6).EQ.TABA(N,LUN)(1: 3)) GOTO 900 IF(NEMO .EQ.TABA(N,LUN)(4:11)) GOTO 900 ENDDO RETURN C CHECK TABLE B AND D C ------------------- ENTRY NENUBD(NEMO,NUMB,LUN) DO N=1,NTBB(LUN) IF(NUMB.EQ.TABB(N,LUN)(1: 6)) GOTO 900 IF(NEMO.EQ.TABB(N,LUN)(7:14)) GOTO 900 ENDDO DO N=1,NTBD(LUN) IF(NUMB.EQ.TABD(N,LUN)(1: 6)) GOTO 900 IF(NEMO.EQ.TABD(N,LUN)(7:14)) GOTO 900 ENDDO RETURN C ERROR EXIT C ---------- 900 CALL BORT('NENUCK - DUPLICATE NEM/NUM '//NEMO//' '//NUMB) END C---------------------------------------------------------------------- C---------------------------------------------------------------------- SUBROUTINE NEWWIN(LUN,IWIN,JWIN) COMMON /USRINT/ NVAL(10),INV(15000,10),VAL(15000,10) REAL*8 VAL C---------------------------------------------------------------------- cfpp$ expand (lstrpc) C---------------------------------------------------------------------- IF(IWIN.EQ.1) THEN JWIN = NVAL(LUN) RETURN ENDIF C REFIND THE JWIN BOUNDARY FROM IWIN C ---------------------------------- NODE = INV(IWIN,LUN) IF(LSTRPC(NODE,LUN).NE.NODE) CALL BORT('NEWWIN - NOT RPC') JWIN = IWIN+VAL(IWIN,LUN) RETURN END C----------------------------------------------------------------------- C----------------------------------------------------------------------- SUBROUTINE NUMTAB(LUN,IDN,NEMO,TAB,IRET) COMMON /REPTAB/ IDNR(5,2),TYPS(5,2),REPS(5,2),LENS(5) COMMON /TABABD/ NTBA(0:10),NTBB(0:10),NTBD(0:10),MTAB(50,10), . IDNA(50,10,2),IDNB(250,10),IDND(250,10), . TABA(50,10),TABB(250,10),TABD(250,10) CHARACTER*(*) NEMO CHARACTER*600 TABD CHARACTER*128 TABB CHARACTER*128 TABA CHARACTER*3 TYPS CHARACTER*1 REPS,TAB C----------------------------------------------------------------------- C----------------------------------------------------------------------- NEMO = ' ' IRET = 0 TAB = ' ' C LOOK FOR A REPLICATOR OR A REPLICATOR FACTOR C -------------------------------------------- IF(IDN.GE.IDNR(1,1) .AND. IDN.LE.IDNR(1,2)) THEN TAB = 'R' IRET = -MOD(IDN,256) RETURN ENDIF DO I=2,5 IF(IDN.EQ.IDNR(I,1)) THEN TAB = 'R' IRET = I RETURN ELSEIF(IDN.EQ.IDNR(I,2)) THEN TAB = 'F' IRET = I RETURN ENDIF ENDDO C LOOK FOR IDN IN TABLE D C ----------------------- DO I=1,NTBD(LUN) IF(IDN.EQ.IDND(I,LUN)) THEN NEMO = TABD(I,LUN)(7:14) TAB = 'D' IRET = I RETURN ENDIF ENDDO C LOOK FOR IDN IN TABLE B C ----------------------- DO I=1,NTBB(LUN) IF(IDN.EQ.IDNB(I,LUN)) THEN NEMO = TABB(I,LUN)(7:14) TAB = 'B' IRET = I RETURN ENDIF ENDDO RETURN END C---------------------------------------------------------------------- C---------------------------------------------------------------------- SUBROUTINE NXTWIN(LUN,IWIN,JWIN) COMMON /USRINT/ NVAL(10),INV(15000,10),VAL(15000,10) REAL*8 VAL C---------------------------------------------------------------------- cfpp$ expand (lstrpc) C---------------------------------------------------------------------- IF(JWIN.EQ.NVAL(LUN)) THEN IWIN = 0 RETURN ENDIF C FIND THE NEXT SEQUENTIAL WINDOW C ------------------------------- NODE = INV(IWIN,LUN) IF(LSTRPC(NODE,LUN).NE.NODE) print*,'bad node=',node,iwin IF(LSTRPC(NODE,LUN).NE.NODE) CALL BORT('NXTWIN - NOT RPC') IF(VAL(JWIN,LUN).EQ.0) THEN IWIN = 0 ELSE IWIN = JWIN JWIN = IWIN+VAL(IWIN,LUN) ENDIF RETURN END C----------------------------------------------------------------------- C----------------------------------------------------------------------- SUBROUTINE OPENBF(LUNIT,IO,LUNDX) COMMON /MSGCWD/ NMSG(10),NSUB(10),MSUB(10),INODE(10),IDATE(10) COMMON /STBFR / IOLUN(10),IOMSG(10) COMMON /QUIET / IPRT CHARACTER*(*) IO LOGICAL SKIPDX,APPEND DATA IFIRST/0/ C----------------------------------------------------------------------- C----------------------------------------------------------------------- IF(IFIRST.EQ.0) THEN CALL WRDLEN CALL BFRINI IFIRST = 1 ENDIF IF(IO.EQ.'QUIET') THEN IPRT = LUNDX RETURN ENDIF C SEE IF A FILE CAN BE OPENED C --------------------------- CALL STATUS(LUNIT,LUN,IL,IM) IF(LUN.EQ.0) GOTO 900 IF(IL .NE.0) GOTO 901 C SET INITIAL OPEN DEFAULTS C ------------------------- NMSG (LUN) = 0 NSUB (LUN) = 0 MSUB (LUN) = 0 INODE(LUN) = 0 IDATE(LUN) = 0 SKIPDX = .FALSE. APPEND = .FALSE. C DECIDE HOW TO SETUP THE DICTIONARY C ---------------------------------- IF(IO.EQ.'IN') THEN CALL WTSTAT(LUNIT,LUN,-1,0) CALL READDX(LUNIT,LUN,LUNDX) ELSE GOTO 903 ENDIF RETURN C ERROR EXITS C ----------- 900 CALL BORT('OPENBF - TOO MANY FILES OPENED ALREADY ') 901 CALL BORT('OPENBF - FILE ALREADY OPEN ') 903 CALL BORT('OPENBF - IO MUST BE "IN" ') END C----------------------------------------------------------------------- C PARSE SEPARATE WORDS FROM A STRING SEQUENCE C----------------------------------------------------------------------- SUBROUTINE PARSEQ(STR,TAGS,MTAG,NTAG) CHARACTER*(*) STR,TAGS(MTAG) CHARACTER*80 ASTR LOGICAL WORD C----------------------------------------------------------------------- C----------------------------------------------------------------------- ASTR = STR LSTR = LEN(STR) LTAG = LEN(TAGS(1)) IF(LSTR.GT.80) GOTO 900 NTAG = 0 NCHR = 0 WORD = .FALSE. DO 10 I=1,LSTR IF(.NOT.WORD .AND. STR(I:I).NE.' ') THEN NTAG = NTAG+1 IF(NTAG.GT.MTAG) GOTO 901 TAGS(NTAG) = ' ' ENDIF IF(WORD .AND. STR(I:I).EQ.' ') NCHR = 0 WORD = STR(I:I).NE.' ' IF(WORD) THEN NCHR = NCHR+1 IF(NCHR.GT.LTAG) GOTO 902 TAGS(NTAG)(NCHR:NCHR) = STR(I:I) ENDIF 10 CONTINUE RETURN 900 CALL BORT('PARSEQ - STRING TOO LONG '//ASTR) 901 CALL BORT('PARSEQ - TOO MANY TAGS '//ASTR) 902 CALL BORT('PARSEQ - TAG IS TOO LONG '//ASTR) END C---------------------------------------------------------------------- C---------------------------------------------------------------------- SUBROUTINE PARUSR(STR,LUN,I1,IO) COMMON /USRSTR/ NNOD,NCON,NODS(20),NODC(10),IVLS(10),KONS(10) common /ACMODE/ iac CHARACTER*(*) STR CHARACTER*80 UST CHARACTER*20 UTG(30) LOGICAL BUMP DATA MAXUSR /30/ DATA MAXNOD /20/ DATA MAXCON /10/ C---------------------------------------------------------------------- C---------------------------------------------------------------------- UST = STR IF(LEN(STR).GT.80) GOTO 900 NCON = 0 NNOD = 0 C PROCESS STRING PIECES(S) INTO COND NODES AND STORE NODES C -------------------------------------------------------- CALL PARSEQ(UST,UTG,MAXUSR,NTOT) DO N=1,NTOT CALL PARUTG(LUN,IO,UTG(N),NOD,KON,VAL,*908) IF(KON.NE.0) THEN NCON = NCON+1 IF(NCON.GT.MAXCON) GOTO 901 NODC(NCON) = NOD KONS(NCON) = KON IVLS(NCON) = NINT(VAL) ELSE NNOD = NNOD+1 IF(NNOD.GT.MAXNOD) GOTO 902 NODS(NNOD) = NOD ENDIF ENDDO C SORT COND NODES IN JUMP/LINK TABLE ORDER C ---------------------------------------- DO I=1,NCON DO J=I+1,NCON IF(NODC(I).GT.NODC(J)) THEN NOD = NODC(I) NODC(I) = NODC(J) NODC(J) = NOD KON = KONS(I) KONS(I) = KONS(J) KONS(J) = KON VAL = IVLS(I) IVLS(I) = IVLS(J) IVLS(J) = VAL ENDIF ENDDO ENDDO C CHECK ON SPECIAL RULES FOR BUMP NODES C ------------------------------------- BUMP = .FALSE. DO N=1,NCON IF(KONS(N).EQ.5) THEN IF(IO.EQ.0) GOTO 903 IF(N.NE.NCON) GOTO 904 BUMP = .TRUE. ENDIF ENDDO C CHECK STORE NODE COUNT AND ALIGNMENT C ------------------------------------ IF(.NOT.BUMP .AND. NNOD.EQ.0) GOTO 905 IF(NNOD.GT.I1) GOTO 906 IRPC = -1 DO I=1,NNOD IF(NODS(I).GT.0) THEN IF(IRPC.LT.0) IRPC = LSTRPC(NODS(I),LUN) IF(IRPC.NE.LSTRPC(NODS(I),LUN).and.iac.eq.0) GOTO 907 ENDIF ENDDO RETURN 900 CALL BORT('PARUSR - USER STRING > 80 CHARS :'//UST) 901 CALL BORT('PARUSR - TOO MANY COND NODES :'//UST) 902 CALL BORT('PARUSR - TOO MANY STOR NODES :'//UST) 903 CALL BORT('PARUSR - BUMP ON INPUT NOT ALLOWED :'//UST) 904 CALL BORT('PARUSR - BUMP MUST BE ON INNER NODE :'//UST) 905 CALL BORT('PARUSR - USER STRING HAS NO STORE NODES :'//UST) 906 CALL BORT('PARUSR - MUST BE AT LEAST I1 STORE NODES:'//UST) 907 CALL BORT('PARUSR - STORE NODES MUST IN ONE REP GRP:'//UST) 908 CALL BORT('PARUSR - PARUTG:' //UST) END C---------------------------------------------------------------------- C---------------------------------------------------------------------- SUBROUTINE PARUTG(LUN,IO,UTG,NOD,KON,VAL,*) COMMON /MSGCWD/ NMSG(10),NSUB(10),MSUB(10),INODE(10),IDATE(10) COMMON /TABLES/ MAXTAB,NTAB,TAG(15000),TYP(15000),KNT(15000), . JUMP(15000),LINK(15000),JMPB(15000), . IBT(15000),IRF(15000),ISC(15000), . ITP(15000),VALI(15000),KNTI(15000), . ISEQ(15000,2),JSEQ(15000) COMMON /UTGPRM/ PICKEY CHARACTER*20 UTG,ATAG CHARACTER*10 TAG CHARACTER*3 TYP,ATYP,BTYP CHARACTER*1 COND(5) DIMENSION BTYP(8),IOK(8) LOGICAL PICKEY DATA NCHK / 8/ DATA BTYP /'SUB','SEQ','REP','RPC','RPS','DRB','DRP','DRS'/ DATA IOK / -1 , -1 , -1 , -1 , -1 , -1 , 0 , 0 / DATA LTG /20/ C---------------------------------------------------------------------- PICKEY = .FALSE. COND(1) = '=' COND(2) = '!' COND(3) = '<' COND(4) = '>' COND(5) = '^' NCOND = 5 C---------------------------------------------------------------------- ATAG = ' ' ATYP = ' ' KON = 0 NOD = 0 VAL = 0 C PARSE THE TAG C ------------- DO I=1,LTG IF(UTG(I:I).EQ.' ') GOTO 1 DO J=1,NCOND IF(UTG(I:I).EQ.COND(J)) THEN KON = J ICV = I+1 GOTO 1 ENDIF ENDDO ATAG(I:I) = UTG(I:I) ENDDO C FIND THE TAG IN THE SUBSET TABLE C -------------------------------- 1 INOD = INODE(LUN) DO NOD=INOD,ISC(INOD) IF(ATAG.EQ.TAG(NOD)) GOTO 2 ENDDO IF(KON.EQ.0 .AND. (IO.EQ.0.OR.ATAG.EQ.'NUL'.OR..NOT.PICKEY)) THEN C IF(KON.EQ.0) THEN NOD = 0 RETURN ELSE PRINT*,'TRYING TO WRITE A NON-EXISTANT MNEMONIC:'//ATAG RETURN 1 ENDIF C CHECK FOR A VALID NODE TYP C -------------------------- 2 IF(KON.EQ.5) THEN IF(TYP(NOD-1).NE.'DRP' .AND. TYP(NOD-1).NE.'DRS') GOTO 901 ELSE ATYP = TYP(NOD) DO I=1,NCHK IF(ATYP.EQ.BTYP(I) .AND. IO.NE.IOK(I)) GOTO 902 ENDDO ENDIF C IF A COND NODE GET THE COND VALUE C --------------------------------- IF(KON.NE.0) THEN CALL STRNUM(UTG(ICV:LTG),NUM) IF(NUM.LT.0) GOTO 903 VAL = NUM ENDIF RETURN 900 CALL BORT('PARUTG - NO VALID TAG FOUND IN :'//UTG) 901 CALL BORT('PARUTG - BUMP NODE MUST BE TYPE RPC(DRP) :'//UTG) 902 CALL BORT('PARUTG - ILLEGAL NODE TYPE:'//ATYP// ':'//UTG) 903 CALL BORT('PARUTG - BAD OR MISSING COND VALUE IN :'//UTG) END C----------------------------------------------------------------------- C----------------------------------------------------------------------- SUBROUTINE PKTDD(ID,LUN,IDN,IRET) COMMON /TABABD/ NTBA(0:10),NTBB(0:10),NTBD(0:10),MTAB(50,10), . IDNA(50,10,2),IDNB(250,10),IDND(250,10), . TABA(50,10),TABB(250,10),TABD(250,10) COMMON /DXTAB / MAXDX,IDXV,NXSTR(10),LDXA(10),LDXB(10),LDXD(10), . LD30(10),DXSTR(10) CHARACTER*600 TABD CHARACTER*128 TABB CHARACTER*128 TABA CHARACTER*56 DXSTR CHARACTER*1 cval BYTE bval EQUIVALENCE ( cval, bval ) C----------------------------------------------------------------------- C----------------------------------------------------------------------- LDD = LDXD(IDXV+1)+1 C ZERO THE COUNTER IF IDN IS ZERO C ------------------------------- IF(IDN.EQ.0) THEN bval = 0 tabd ( id, lun ) ( ldd:ldd ) = cval IRET = 0 RETURN ENDIF C UPDATE THE STORED DESCRIPTOR COUNT FOR THIS TABLE D ENTRY C --------------------------------------------------------- cval = tabd ( id, lun ) ( ldd:ldd ) nd = bval IF(ND.LT.0 .OR. ND.EQ.250) THEN IRET = -1 RETURN ELSE ND = ND+1 bval = nd tabd ( id, lun ) ( ldd:ldd ) = cval IRET = ND ENDIF C PACK AND STORE THE DESCRIPTOR C ----------------------------- IDM = LDD+1 + (ND-1)*2 CALL MV_ITOB ( idn, idm-1, 2, tabd ( id, lun ), jret ) RETURN END C---------------------------------------------------------------------- C---------------------------------------------------------------------- SUBROUTINE RCSTPL(LUN) PARAMETER (MAXTMP=1000) PARAMETER (MAXINV=15000) PARAMETER (MAXRCR=100 ) COMMON /BITBUF/ MAXBYT,IBIT,IBAY(3000),MBYT(10),MBAY(3000,10) COMMON /MSGCWD/ NMSG(10),NSUB(10),MSUB(10),INODE(10),IDATE(10) COMMON /TABLES/ MAXTAB,NTAB,TAG(15000),TYP(15000),KNT(15000), . JUMP(15000),LINK(15000),JMPB(15000), . IBT(15000),IRF(15000),ISC(15000), . ITP(15000),VALI(15000),KNTI(15000), . ISEQ(15000,2),JSEQ(15000) COMMON /USRINT/ NVAL(10),INV(15000,10),VAL(15000,10) COMMON /USRBIT/ NBIT(15000),MBIT(15000) CHARACTER*10 TAG CHARACTER*3 TYP DIMENSION ITMP(MAXTMP,MAXRCR),VTMP(MAXTMP,MAXRCR) DIMENSION NBMP(2,MAXRCR),NEWN(2,MAXRCR) DIMENSION KNX(MAXRCR) REAL*8 VAL,VTMP C----------------------------------------------------------------------- CFPP$ EXPAND (UPBB) C----------------------------------------------------------------------- C SET THE INITIAL VALUES FOR THE TEMPLATE C --------------------------------------- INV(1,LUN) = INODE(LUN) VAL(1,LUN) = 0 NBMP(1,1) = 1 NBMP(2,1) = 1 NODI = INODE(LUN) NODE = INODE(LUN) MBMP = 1 KNVN = 1 NR = 0 DO I=1,MAXRCR KNX(I) = 0 ENDDO C SET UP THE PARAMETRES FOR A LEVEL OF RECURSION C ---------------------------------------------- 10 CONTINUE NR = NR+1 NBMP(1,NR) = 1 NBMP(2,NR) = MBMP N1 = ISEQ(NODE,1) N2 = ISEQ(NODE,2) IF(N1.EQ.0 ) GOTO 905 IF(N2-N1+1.GT.MAXTMP) GOTO 906 NEWN(1,NR) = 1 NEWN(2,NR) = N2-N1+1 DO N=1,NEWN(2,NR) NN = JSEQ(N+N1-1) ITMP(N,NR) = NN VTMP(N,NR) = VALI(NN) if(vtmp(n,nr).gt.10e9) vtmp(n,nr) = 10e10 ENDDO C STORE NODES AT SOME RECURSION LEVEL C ----------------------------------- 20 DO I=NBMP(1,NR),NBMP(2,NR) IF(KNX(NR).EQ.0000) KNX(NR) = KNVN IF(I.GT.NBMP(1,NR)) NEWN(1,NR) = 1 DO J=NEWN(1,NR),NEWN(2,NR) KNVN = KNVN+1 NODE = ITMP(J,NR) INV(KNVN,LUN) = NODE VAL(KNVN,LUN) = VTMP(J,NR) MBIT(KNVN) = MBIT(KNVN-1)+NBIT(KNVN-1) NBIT(KNVN) = IBT(NODE) IF(ITP(NODE).EQ.1) THEN CALL UPBB(MBMP,NBIT(KNVN),MBIT(KNVN),MBAY(1,LUN)) NEWN(1,NR) = J+1 NBMP(1,NR) = I GOTO 10 ENDIF ENDDO NEW = KNVN-KNX(NR) VAL(KNX(NR)+1,LUN) = VAL(KNX(NR)+1,LUN) + NEW KNX(NR) = 0 ENDDO C CONTINUE AT ONE RECUSION LEVEL BACK C ----------------------------------- IF(NR-1.NE.0) THEN NR = NR-1 GOTO 20 ENDIF C FINALLY STORE THE LENGTH OF THE SUBSET TEMPLATE C ----------------------------------------------- NVAL(LUN) = KNVN C NORMAL EXIT C ----------- RETURN C ERROR EXITS C ----------- 900 CALL BORT('RCSTPL - NBMP <> 1 FOR : '//TAG(NODI)) 901 CALL BORT('RCSTPL - NODE NOT SUB,DRP,DRS : '//TAG(NODI)) 902 CALL BORT('RCSTPL - NEGATIVE REP FACTOR : '//TAG(NODI)) 903 CALL BORT('RCSTPL - REP FACTOR OVERFLOW : '//TAG(NODI)) 904 CALL BORT('RCSTPL - INVENTORY INDEX OUT OF BOUNDS ') 905 CALL BORT('RCSTPL - UNSET EXPANSION SEG : '//TAG(NODI)) 906 CALL BORT('RCSTPL - TEMP ARRAY OVERFLOW : '//TAG(NODI)) 907 CALL BORT('RCSTPL - INVENTORY OVERFLOW : '//TAG(NODI)) 908 CALL BORT('RCSTPL - TPL CACHE OVERFLOW : '//TAG(NODI)) 909 CALL BORT('RCSTPL - BAD BACKUP STRATEGY : '//TAG(NODI)) END C----------------------------------------------------------------------- C----------------------------------------------------------------------- SUBROUTINE RDBFDX(LUNIT,LUN) COMMON /HRDWRD/ NBYTW,NBITW,NREV,IORD(8) COMMON /TABABD/ NTBA(0:10),NTBB(0:10),NTBD(0:10),MTAB(50,10), . IDNA(50,10,2),IDNB(250,10),IDND(250,10), . TABA(50,10),TABB(250,10),TABD(250,10) COMMON /DXTAB / MAXDX,IDXV,NXSTR(10),LDXA(10),LDXB(10),LDXD(10), . LD30(10),DXSTR(10) COMMON / BUFMSG / barray, nbytes, jbfr1 CHARACTER*600 TABD CHARACTER*128 TABB,TABB1,TABB2 CHARACTER*128 TABA CHARACTER*56 DXSTR CHARACTER*50 DXCMP CHARACTER*8 NEMO CHARACTER*6 NUMB,CIDN CHARACTER*1 moct(24000) DIMENSION LDXBD(10),LDXBE(10) BYTE barray (24000) EQUIVALENCE (MOCT(1), barray ( 1 ) ) LOGICAL DIGIT DATA LDXBD /38,70,8*0/ DATA LDXBE /42,42,8*0/ C----------------------------------------------------------------------- JA(I) = IA+1+LDA*(I-1) JB(I) = IB+1+LDB*(I-1) C----------------------------------------------------------------------- C INITIALIZE THE DX-TABLE PARTITION AND SOURCE FILE C ------------------------------------------------- jbfr1 = 0 CALL DXINIT(LUN,0) C CLEAR THE BUFFER AND READ A MESSAGE C ----------------------------------- 1 DO I=1,24000 barray ( i ) = 0 ENDDO CALL CBF_READ ( barray, nbytes, iostat ) C CHECK FOR NO BUFR DATA OR NO DATA AT ALL C ---------------------------------------- IF ( iostat .ne. 0 ) GO TO 911 C GET THE SECTION START OCTETS AND LENGTHS C ---------------------------------------- i1 = 8 CALL MV_BTOI ( barray, i1, 3, .false., l1, jret ) i2 = i1+l1 IF ( barray ( i1+8 ) .ge. 0 ) THEN l2 = 0 ELSE CALL MV_BTOI ( barray, i2, 3, .false., l2, jret ) END IF i3 = i2+l2 CALL MV_BTOI ( barray, i3, 3, .false., l3, jret ) i4 = i3+l3 CALL MV_BTOI ( barray, i4, 3, .false., l4, jret ) C SEE IF THIS IS A BUFR DX MESSAGE - CHECK FOR RECOGNISABLE DX VERSION C -------------------------------------------------------------------- IF ( barray ( i1+9 ) .ne. 11 ) THEN CALL MAKESTAB jbfr1 = 1 RETURN ENDIF IDXS = barray ( i1 + 10 ) + 1 IF(LDXA(IDXS).EQ.0) GOTO 902 IF(LDXB(IDXS).EQ.0) GOTO 902 IF(LDXD(IDXS).EQ.0) GOTO 902 L30 = LD30(IDXS) DXCMP = ' ' CALL CHRTRN(DXCMP,MOCT(I3+8),NXSTR(IDXS)) IF(DXCMP.NE.DXSTR(IDXS)) GOTO 902 C SECTION 4 - READ DEFINITIONS FOR TABLES A B AND D C ------------------------------------------------- LDA = LDXA (IDXS) LDB = LDXB (IDXS) LDD = LDXD (IDXS) LDBD = LDXBD(IDXS) LDBE = LDXBE(IDXS) IA = I4+5 LA = barray ( ia ) IB = JA(LA+1) LB = barray ( ib ) ID = JB(LB+1) LD = barray ( id ) C TABLE A - MESSAGE TYPE/SUBTYPE FROM THE NEMONIC OR THE SEQ NUMBER C ----------------------------------------------------------------- DO I=1,LA N = NTBA(LUN)+1 IF(N.GT.NTBA(0)) GOTO 903 CALL CHRTRN(TABA(N,LUN),MOCT(JA(I)),LDA) NUMB = ' '//TABA(N,LUN)(1:3) NEMO = TABA(N,LUN)(4:11) CALL NENUAA(NEMO,NUMB,LUN) NTBA(LUN) = N IF(DIGIT(NEMO(3:8))) THEN READ(NEMO,'(2X,2I3)') MTYP,MSBT IDNA(N,LUN,1) = MTYP IDNA(N,LUN,2) = MSBT ELSE READ(NUMB(4:6),'(I3)') IDNA(N,LUN,1) IDNA(N,LUN,2) = 0 ENDIF ENDDO C TABLE B C ------- DO I=1,LB N = NTBB(LUN)+1 IF(N.GT.NTBB(0)) GOTO 904 CALL CHRTRN(TABB1,MOCT(JB(I) ),LDBD) CALL CHRTRN(TABB2,MOCT(JB(I)+LDBD),LDBE) TABB(N,LUN) = TABB1(1:LDXBD(IDXV+1))//TABB2(1:LDXBE(IDXV+1)) NUMB = TABB(N,LUN)(1:6) NEMO = TABB(N,LUN)(7:14) CALL NENUBD(NEMO,NUMB,LUN) IDNB(N,LUN) = IFXY(NUMB) NTBB(LUN) = N ENDDO C TABLE D C ------- DO I=1,LD N = NTBD(LUN)+1 IF(N.GT.NTBD(0)) GOTO 905 CALL CHRTRN(TABD(N,LUN),MOCT(ID+1),LDD) NUMB = TABD(N,LUN)(1:6) NEMO = TABD(N,LUN)(7:14) CALL NENUBD(NEMO,NUMB,LUN) IDND(N,LUN) = IFXY(NUMB) ND = barray ( id + ldd + 1 ) IF(ND.GT.250) GOTO 906 DO J=1,ND NDD = ID+LDD+2 + (J-1)*L30 CALL CHRTRN(CIDN,MOCT(NDD),L30) IDN = IDN30(CIDN,L30) CALL PKTDD(N,LUN,IDN,IRET) IF(IRET.LT.0) GOTO 908 ENDDO ID = ID+LDD+1 + ND*L30 IF ( barray ( id +1 ) .eq. 0) id = id + 1 NTBD(LUN) = N ENDDO C GOTO READ THE NEXT MESSAGE C -------------------------- GOTO 1 C ERROR EXITS C ----------- 900 CALL BORT('RDBFDX - I/O ERROR READING DX MESSAGE ') 901 CALL BORT('RDBFDX - EOF >>>>> READING DX MESSAGE ') 902 CALL BORT('RDBFDX - UNEXPECTED DX MESSAGE TYPE OR CONTENTS') 903 CALL BORT('RDBFDX - TOO MANY TABLE A ENTRIES ') 904 CALL BORT('RDBFDX - TOO MANY TABLE B ENTRIES ') 905 CALL BORT('RDBFDX - TOO MANY TABLE D ENTRIES ') 906 CALL BORT('RDBFDX - TOO MANY DESCRIPTORS IN TABLE D ENTRY ') 907 CALL BORT('RDBFDX - ERROR READING IDN SEQ FROM MOCT ') 908 CALL BORT('RDBFDX - BAD RETURN FROM PKTDD ') 909 CALL BORT('RDBFDX - DESC COUNT IN TABD <> MOCT ') 910 CALL BORT('RDBFDX - ERR/EOF POSITIONING AFTER DX MESSAGES ') 911 CALL BORT('RDBFDX - INPUT FILE HAS NON-BUFR DATA ') END C---------------------------------------------------------------------- C---------------------------------------------------------------------- SUBROUTINE RDTREE(LUN) COMMON /BITBUF/ MAXBYT,IBIT,IBAY(3000),MBYT(10),MBAY(3000,10) COMMON /MSGCWD/ NMSG(10),NSUB(10),MSUB(10),INODE(10),IDATE(10) COMMON /TABLES/ MAXTAB,NTAB,TAG(15000),TYP(15000),KNT(15000), . JUMP(15000),LINK(15000),JMPB(15000), . IBT(15000),IRF(15000),ISC(15000), . ITP(15000),VALI(15000),KNTI(15000), . ISEQ(15000,2),JSEQ(15000) COMMON /USRINT/ NVAL(10),INV(15000,10),VAL(15000,10) COMMON /USRBIT/ NBIT(15000),MBIT(15000) CHARACTER*10 TAG CHARACTER*8 CVAL CHARACTER*3 TYP DIMENSION IVAL(15000) EQUIVALENCE (CVAL,RVAL) REAL*8 VAL,RVAL C----------------------------------------------------------------------- CFPP$ EXPAND (UPBB) C----------------------------------------------------------------------- MPS(NODE) = 2**(IBT(NODE))-1 UPS(NODE) = (IVAL(N)+IRF(NODE))*10.**(-ISC(NODE)) C----------------------------------------------------------------------- C CYCLE THROUGH A SUBSET SETTING UP THE USER ARRAY C ------------------------------------------------ MBIT(1) = IBIT NBIT(1) = 0 CALL RCSTPL(LUN) C UNPACK A SUBSET INTO THE USER ARRAY C ----------------------------------- DO N=1,NVAL(LUN) CALL UPBB(IVAL(N),NBIT(N),MBIT(N),MBAY(1,LUN)) ENDDO C CONVERT THE UNPACKED INTEGERS TO THE PROPER TYPES C ------------------------------------------------- DO N=1,NVAL(LUN) NODE = INV(N,LUN) IF(ITP(NODE).EQ.1) THEN VAL(N,LUN) = IVAL(N) ELSEIF(ITP(NODE).EQ.2) THEN IF(IVAL(N).LT.MPS(NODE)) VAL(N,LUN) = UPS(NODE) ENDIF ENDDO C SPECIAL TREATMENT FOR CHARACTERS C -------------------------------- DO N=1,NVAL(LUN) NODE = INV(N,LUN) IF(ITP(NODE).EQ.3) THEN CVAL = ' ' CALL UPC(CVAL,NBIT(N)/8,MBAY(1,LUN),MBIT(N)) VAL(N,LUN) = RVAL ENDIF ENDDO RETURN END C----------------------------------------------------------------------- C BUFR TABLE INFORMATION CONTAINED IN A FILE CONNECTED TO UNIT LUNDX C IS USED TO INITIALIZE PROCESSING TABLES FOR A BUFR FILE CONNECTED C TO UNIT LUNIT. LUNIT AND LUNDX MAY BE THE SAME ONLY IF THE UNIT IS C CONNECTED TO A BUFR FILE, CURRENTLY OPEN FOR INPUT PROCESSING, C POSITIONED AT A DX-TABLE MESSAGE (ANYWHERE IN THE FILE). OTHERWISE, C LUNDX MAY BE CONNECTED TO ANOTHER CURRENTLY OPEN AND DEFINED BUFR C FILE, OR TO A USER SUPPLIED, CHARACTER FORMAT, DX-TABLE FILE. C C NOTE: READDX IS USED TO INITIALIZE INTERNAL BUFR DX-TABLES ONLY. C IF A BUFR OUTPUT FILE IS BEING OPENED, SUBROUTINE WRITDX C CALLS READDX TO INITIALIZE THE INTERNAL DX-TABLES, AND THEN C WRITES BUFR DX-TABLE MESSAGES INTO THE OUTPUT FILE. C C C INPUT ARGUMENTS: C LUNIT - UNIT CONNECTED TO BUFR FILE TO BE INITIALIZED/UPDATED C LUN - INTERNAL BUFR UNIT ASSOCIATED WITH FORTRAN UNIT LUNIT C LUNDX - UNIT CONTAINING DX-TABLES C C----------------------------------------------------------------------- SUBROUTINE READDX(LUNIT,LUN,LUNDX) COMMON /QUIET/ IPRT C----------------------------------------------------------------------- C----------------------------------------------------------------------- C GET THE BUFR STATUS OF UNIT LUNDX C --------------------------------- CALL STATUS(LUNDX,LUD,ILDX,IMDX) C READ A DX-TABLE FROM THE INDICATED SOURCE C ----------------------------------------- IF (LUNIT.EQ.LUNDX) THEN IF(IPRT.GE.1) PRINT100,LUNDX,LUNIT CALL RDBFDX(LUNIT,LUN) ELSE CALL BORT('READDX - SCREWUP') ENDIF 100 FORMAT(' READING BUFR DX-TABLES FROM ',I2,' TO ',I2) RETURN END C----------------------------------------------------------------------- C----------------------------------------------------------------------- SUBROUTINE READMG(LUNIT,SUBSET,JDATE,IRET) COMMON /HRDWRD/ NBYTW,NBITW,NREV,IORD(8) COMMON /MSGCWD/ NMSG(10),NSUB(10),MSUB(10),INODE(10),IDATE(10) COMMON /BITBUF/ MAXBYT,IBIT,IBAY(3000),MBYT(10),MBAY(3000,10) COMMON /DATELN/ LENDAT COMMON / BUFMSG / barray, nbytes, jbfr1 CHARACTER*8 SUBSET CHARACTER*6 ADN30,TABAX CHARACTER*1 TAB INTEGER iarray ( 3000 ) BYTE barray (24000) EQUIVALENCE ( barray (1), iarray (1) ) C----------------------------------------------------------------------- C----------------------------------------------------------------------- IRET = 0 C CHECK THE FILE STATUS C --------------------- CALL STATUS(LUNIT,LUN,IL,IM) IF(IL.EQ.0) GOTO 900 IF(IL.GT.0) GOTO 901 CALL WTSTAT(LUNIT,LUN,IL,1) C READ A MESSAGE INTO A MESSAGE BUFFER - SKIP DX MESSAGES C ------------------------------------------------------- 1 IF ( jbfr1 .eq. 0 ) THEN CALL CBF_READ ( barray, nbytes, iostat ) IF ( iostat .ne. 0 ) GO TO 100 ELSE jbfr1 = 0 END IF lenmsg = nbytes / nbytw IF ( ( nbytw * lenmsg ) .ne. nbytes ) lenmsg = lenmsg + 1 IF ( nrev .eq. 0 ) THEN DO i = 1, lenmsg mbay ( i, lun ) = iarray ( i ) END DO ELSE iret = MV_SWP4 ( lenmsg, iarray, mbay ( 1, lun ) ) END IF C SECTION 1 C --------- IAD1 = 8 LEN1 = IUPB(MBAY(1,LUN),IAD1+ 1,24) LEN2 = IUPB(MBAY(1,LUN),IAD1+ 8, 1) MTYP = IUPB(MBAY(1,LUN),IAD1+ 9, 8) MSBT = IUPB(MBAY(1,LUN),IAD1+10, 8) MEAR = MOD(IUPB(MBAY(1,LUN),IAD1+13, 8),100) MMON = IUPB(MBAY(1,LUN),IAD1+14, 8) MDAY = IUPB(MBAY(1,LUN),IAD1+15, 8) MOUR = IUPB(MBAY(1,LUN),IAD1+16, 8) MMIN = IUPB(MBAY(1,LUN),IAD1+17, 8) MCEN = MAX(0,IUPB(MBAY(1,LUN),IAD1+18, 8)-MIN(MEAR,1)) IF(LENDAT.EQ.10) THEN JDATE = MCEN*10**8+MEAR*10**6+MMON*10**4+MDAY*10**2+MOUR JDATE = I4DY(JDATE) ELSE JDATE = MEAR*10**6+MMON*10**4+MDAY*10**2+MOUR ENDIF IF(MTYP.EQ.11) GOTO 1 C SECTION 2 C --------- IAD2 = IAD1+LEN1 LEN2 = IUPB(MBAY(1,LUN),IAD2+1,24) * LEN2 C SECTION 3 C --------- IAD3 = IAD2+LEN2 LEN3 = IUPB(MBAY(1,LUN),IAD3+1 ,24) JSUB = IUPB(MBAY(1,LUN),IAD3+5 ,16) ISUB = IUPB(MBAY(1,LUN),IAD3+10,16) CALL NUMTAB(LUN,ISUB,SUBSET,TAB,ITAB) IF(ITAB.EQ.0) THEN TABAX = ADN30(ISUB,6) PRINT*,'UNRECOGNISED TABLE A DESCRIPTOR:',TABAX GOTO 1 ENDIF CALL NEMTBA(LUN,SUBSET,MTY1,MSB1,INOD) IF(MTYP.NE.MTY1 .OR. MSBT.NE.MSB1) GOTO 903 C SECTION 4 C --------- IAD4 = IAD3+LEN3 LEN4 = IUPB(MBAY(1,LUN),IAD4+1,24) MBYT(LUN) = IAD4+4 C NORMAL EXIT C ----------- IDATE(LUN) = I4DY(JDATE) INODE(LUN) = INOD MSUB (LUN) = JSUB NSUB (LUN) = 0 NMSG (LUN) = NMSG(LUN)+1 IRET = 0 RETURN C EOF ON ATTEMPTED READ C --------------------- 100 CALL WTSTAT(LUNIT,LUN,IL,0) INODE(LUN) = 0 IDATE(LUN) = 0 SUBSET = ' ' JDATE = 0 IRET = -1 RETURN C ENTRY DATELEN SETS THE LENGTH OF THE DATE INTEGER RETURN FROM READS C ------------------------------------------------------------------- ENTRY DATELEN(LEN) IF(LEN.NE.8 .AND. LEN.NE.10) CALL BORT('DATELEN - BAD LEN') LENDAT = LEN RETURN C ERROR EXITS C ----------- 900 CALL BORT('READMG - FILE IS CLOSED ') 901 CALL BORT('READMG - FILE IS OPEN FOR OUTPUT ') 902 CALL BORT('READMG - I/O ERROR READING MESSAGE ') 903 CALL BORT('READMG - MSGTYPE MISMATCH FOR '//SUBSET ) END C---------------------------------------------------------------------- C---------------------------------------------------------------------- SUBROUTINE READSB(LUNIT,IRET) COMMON /MSGCWD/ NMSG(10),NSUB(10),MSUB(10),INODE(10),IDATE(10) COMMON /BITBUF/ MAXBYT,IBIT,IBAY(3000),MBYT(10),MBAY(3000,10) C----------------------------------------------------------------------- CFPP$ EXPAND(STATUS) C----------------------------------------------------------------------- IRET = 0 C CHECK THE FILE STATUS C --------------------- CALL STATUS(LUNIT,LUN,IL,IM) IF(IL.EQ.0) GOTO 900 IF(IL.GT.0) GOTO 901 IF(IM.EQ.0) THEN IRET = -1 RETURN ENDIF C SEE IF THERE IS ANOTHER SUBSET IN THE MESSAGE C --------------------------------------------- IF(NSUB(LUN).EQ.MSUB(LUN)) THEN IRET = -1 RETURN ENDIF C READ THE NEXT SUBSET AND RESET THE POINTERS C ------------------------------------------- IBIT = MBYT(LUN)*8 CALL UPB(NBYT,16,MBAY(1,LUN),IBIT) CALL RDTREE(LUN) MBYT(LUN) = MBYT(LUN) + NBYT NSUB(LUN) = NSUB(LUN) + 1 RETURN 900 CALL BORT('READSB - FILE IS CLOSED ') 901 CALL BORT('READSB - FILE IS OPEN FOR OUTPUT ') 902 CALL BORT('READSB - NO MESSAGE OPEN ') END C----------------------------------------------------------------------- C----------------------------------------------------------------------- FUNCTION RJUST(STR) CHARACTER*(*) STR RJUST = 0 IF(STR.EQ.' ') RETURN LSTR = LEN(STR) DO WHILE(STR(LSTR:LSTR).EQ.' ') DO I=LSTR,2,-1 STR(I:I) = STR(I-1:I-1) ENDDO STR(1:1) = ' ' ENDDO RETURN END C----------------------------------------------------------------------- C----------------------------------------------------------------------- SUBROUTINE RSVFVM(NEM1,NEM2) CHARACTER*8 NEM1,NEM2 DO I=1,LEN(NEM1) IF(I.EQ.1) THEN J = 1 ELSE IF(NEM1(I:I).EQ.'.') THEN NEM1(I:I) = NEM2(J:J) J = J+1 ENDIF ENDIF ENDDO RETURN END C----------------------------------------------------------------------- C----------------------------------------------------------------------- SUBROUTINE STATUS(LUNIT,LUN,IL,IM) COMMON /STBFR/ IOLUN(10),IOMSG(10) C----------------------------------------------------------------------- C----------------------------------------------------------------------- IF(LUNIT.LE.0 .OR. LUNIT.GT.99) GOTO 900 C CLEAR THE STATUS INDICATORS C --------------------------- LUN = 0 IL = 0 IM = 0 C SEE IF THE UNIT IS DEFINED C -------------------------- DO I=1,10 IF(ABS(IOLUN(I)).EQ.LUNIT) LUN = I ENDDO C IF NOT, CHECK FOR FILE SPACE - RETURN LUN=0 IF NO FILE SPACE C ------------------------------------------------------------ IF(LUN.EQ.0) THEN DO I=1,10 IF(IOLUN(I).EQ.0) LUN = I IF(IOLUN(I).EQ.0) RETURN ENDDO RETURN ENDIF C IF FILE DEFINED RETURN STATUSES C ------------------------------- IL = SIGN(1,IOLUN(LUN)) IM = IOMSG(LUN) RETURN 900 CALL BORT('STATUS - ILLEGAL UNIT GIVEN') END C---------------------------------------------------------------------- C ENTRY TO RESET STRING CACHE C---------------------------------------------------------------------- SUBROUTINE STRCLN PARAMETER(MXS=1000) COMMON /STCACH/ MSTR,NSTR,LSTR,LUNS(MXS,2),USRS(MXS),ICON(52,MXS) CHARACTER*80 USRS MSTR = MXS NSTR = 0 LSTR = 0 RETURN END C---------------------------------------------------------------------- C---------------------------------------------------------------------- SUBROUTINE STRING(STR,LUN,I1,IO) PARAMETER (MXS=1000,JCONS=52) COMMON /MSGCWD/ NMSG(10),NSUB(10),MSUB(10),INODE(10),IDATE(10) COMMON /STCACH/ MSTR,NSTR,LSTR,LUX(MXS,2),USR(MXS),ICON(52,MXS) COMMON /USRSTR/ JCON(JCONS) COMMON /STORDS/ IORD(MXS),IORX(MXS) CHARACTER*(*) STR CHARACTER*80 USR,UST C---------------------------------------------------------------------- C---------------------------------------------------------------------- NXT = 0 UST = STR IND = INODE(LUN) IF(LEN(STR).GT.80) GOTO 900 C SEE IF STRING IS IN THE CACHE C ----------------------------- DO N=1,NSTR IF(LUX(IORD(N),2).EQ.IND) THEN IORX(NXT+1) = IORD(N) NXT = NXT+1 ENDIF ENDDO DO N=1,NXT IF(UST.EQ.USR(IORX(N)))GOTO1 ENDDO GOTO2 C IF IT IS COPY PARAMETERS FROM THE CACHE C --------------------------------------- 1 DO J=1,JCONS JCON(J) = ICON(J,IORX(N)) ENDDO GOTO 100 C IF NOT PARSE IT AND PUT IT THERE C -------------------------------- 2 CALL PARUSR(STR,LUN,I1,IO) LSTR = MAX(MOD(LSTR+1,MSTR+1),1) NSTR = MIN(NSTR+1,MSTR) LUX(LSTR,1) = LUN LUX(LSTR,2) = IND USR(LSTR) = STR DO J=1,JCONS ICON(J,LSTR) = JCON(J) ENDDO C REARRANGE THE CACHE ORDER AFTER AN UPDATE C ----------------------------------------- DO N=NSTR,2,-1 IORD(N) = IORD(N-1) ENDDO IORD(1) = LSTR C NORMAL AND ERROR EXITS C ---------------------- 100 IF(JCON(1).GT.I1) GOTO 901 RETURN 900 CALL BORT('STRING - USER STRING > 80 CHARS :'//UST) 901 CALL BORT('STRING - MUST BE AT LEAST I1 STORE NODES:'//UST) END C----------------------------------------------------------------------- C INTEGER FROM A STRING C----------------------------------------------------------------------- SUBROUTINE STRNUM(STR,NUM) CHARACTER*(*) STR CHARACTER*20 STR2 C----------------------------------------------------------------------- C----------------------------------------------------------------------- NUM = 0 K = 0 CALL STRSUC(STR,STR2,NUM) DO I=1,NUM READ(STR(I:I),'(I1)',ERR=99) J IF(J.EQ.0 .AND. STR(I:I).NE.'0') GOTO 99 K = K*10+J ENDDO NUM = K RETURN 99 NUM = -1 RETURN END C----------------------------------------------------------------------- C DEAD SPACE FORM A STRING C----------------------------------------------------------------------- SUBROUTINE STRSUC(STR1,STR2,LENS) CHARACTER*(*) STR1,STR2 C----------------------------------------------------------------------- C----------------------------------------------------------------------- LENS = 0 LSTR = LEN(STR1) DO I=1,LSTR IF(STR1(I:I).NE.' ') GOTO 2 ENDDO RETURN 2 DO J=I,LSTR IF(STR1(J:J).EQ.' ') GOTO 3 LENS = LENS+1 STR2(LENS:LENS) = STR1(J:J) ENDDO RETURN 3 DO I=J,LSTR IF(STR1(I:I).NE.' ') LENS = -1 ENDDO RETURN END C----------------------------------------------------------------------- C----------------------------------------------------------------------- SUBROUTINE TABENT(LUN,NEMO,TAB,ITAB,IREP,IKNT,JUM0) COMMON /REPTAB/ IDNR(5,2),TYPS(5,2),REPS(5,2),LENS(5) COMMON /TABLES/ MAXTAB,NTAB,TAG(15000),TYP(15000),KNT(15000), . JUMP(15000),LINK(15000),JMPB(15000), . IBT(15000),IRF(15000),ISC(15000), . ITP(15000),VALI(15000),KNTI(15000), . ISEQ(15000,2),JSEQ(15000) CHARACTER*24 UNIT CHARACTER*10 TAG,RTAG CHARACTER*8 NEMO CHARACTER*3 TYP,TYPS,TYPT CHARACTER*1 REPS,TAB C----------------------------------------------------------------------- C----------------------------------------------------------------------- C MAKE A JUMP/LINK TABLE ENTRY FOR A REPLICATOR C --------------------------------------------- IF(IREP.NE.0) THEN RTAG = REPS(IREP,1)//NEMO DO I=1,10 IF(RTAG(I:I).EQ.' ') THEN RTAG(I:I) = REPS(IREP,2) CALL INCTAB(RTAG,TYPS(IREP,1),NODE) JUMP(NODE) = NODE+1 JMPB(NODE) = JUM0 LINK(NODE) = 0 IBT (NODE) = LENS(IREP) IRF (NODE) = 0 ISC (NODE) = 0 IF(IREP.EQ.1) IRF(NODE) = IKNT JUM0 = NODE GOTO 1 ENDIF ENDDO GOTO 900 ENDIF C MAKE AN JUMP/LINK ENTRY FOR AN ELEMENT OR A SEQUENCE C ---------------------------------------------------- 1 IF(TAB.EQ.'B') THEN CALL NEMTBB(LUN,ITAB,UNIT,ISCL,IREF,IBIT) IF(UNIT(1:5).EQ.'CCITT') TYPT = 'CHR' IF(UNIT(1:5).NE.'CCITT') TYPT = 'NUM' CALL INCTAB(NEMO,TYPT,NODE) JUMP(NODE) = 0 JMPB(NODE) = JUM0 LINK(NODE) = 0 IBT (NODE) = IBIT IRF (NODE) = IREF ISC (NODE) = ISCL ELSEIF(TAB.EQ.'D') THEN IF(IREP.EQ.0) TYPT = 'SEQ' IF(IREP.NE.0) TYPT = TYPS(IREP,2) CALL INCTAB(NEMO,TYPT,NODE) JUMP(NODE) = NODE+1 JMPB(NODE) = JUM0 LINK(NODE) = 0 IBT (NODE) = 0 IRF (NODE) = 0 ISC (NODE) = 0 ELSE GOTO 901 ENDIF RETURN 900 CALL BORT('TABENT - REPLICATOR ERROR: '//RTAG//':'//NEMO) 901 CALL BORT('TABENT - UNDEFINED TAG : ' //NEMO) END C----------------------------------------------------------------------- C----------------------------------------------------------------------- SUBROUTINE TABSUB(LUN,NEMO) COMMON /TABLES/ MAXTAB,NTAB,TAG(15000),TYP(15000),KNT(15000), . JUMP(15000),LINK(15000),JMPB(15000), . IBT(15000),IRF(15000),ISC(15000), . ITP(15000),VALI(15000),KNTI(15000), . ISEQ(15000,2),JSEQ(15000) CHARACTER*10 TAG CHARACTER*8 NEMO,NEMS,NEM CHARACTER*3 TYP CHARACTER*1 TAB DIMENSION NEM(250,10),IRP(250,10),KRP(250,10) DIMENSION DROP(10),JMP0(10),NODL(10),NTAG(10,2) LOGICAL DROP DATA MAXLIM /10/ C----------------------------------------------------------------------- C----------------------------------------------------------------------- C CHECK THE MNEMONIC C ------------------ CALL NEMTAB(LUN,NEMO,IDN,TAB,ITAB) IF(TAB.NE.'D') GOTO 900 C STORE A SUBSET NODE AND JUMP/LINK THE TREE C ------------------------------------------ CALL INCTAB(NEMO,'SUB',NODE) JUMP(NODE) = NODE+1 JMPB(NODE) = 0 LINK(NODE) = 0 IBT (NODE) = 0 IRF (NODE) = 0 ISC (NODE) = 0 CALL NEMTBD(LUN,ITAB,NSEQ,NEM(1,1),IRP(1,1),KRP(1,1)) NTAG(1,1) = 1 NTAG(1,2) = NSEQ JMP0(1) = NODE LIMB = 1 C THIS LOOP RESOLVES ENTITIES IN A SUBSET BY EMULATING RECURSION C -------------------------------------------------------------- 1 DO N=NTAG(LIMB,1),NTAG(LIMB,2) NTAG(LIMB,1) = N+1 NODL(LIMB) = NTAB+1 DROP(LIMB) = N.EQ.NTAG(LIMB,2) CALL NEMTAB(LUN,NEM(N,LIMB),IDN,TAB,ITAB) NEMS = NEM(N,LIMB) IREP = IRP(N,LIMB) IKNT = KRP(N,LIMB) JUM0 = JMP0(LIMB) CALL TABENT(LUN,NEMS,TAB,ITAB,IREP,IKNT,JUM0) IF(TAB.EQ.'D') THEN LIMB = LIMB+1 IF(LIMB.GT.MAXLIM) GOTO 901 CALL NEMTBD(LUN,ITAB,NSEQ,NEM(1,LIMB),IRP(1,LIMB),KRP(1,LIMB)) NTAG(LIMB,1) = 1 NTAG(LIMB,2) = NSEQ JMP0(LIMB) = NTAB GOTO 1 ELSE IF(DROP(LIMB)) THEN 2 LINK(NODL(LIMB)) = 0 LIMB = LIMB-1 IF(LIMB.EQ.0 ) RETURN IF(DROP(LIMB)) GOTO 2 LINK(NODL(LIMB)) = NTAB+1 GOTO 1 ELSE LINK(NODL(LIMB)) = NTAB+1 ENDIF ENDDO CALL BORT('TABSUB - SHOULD NOT GET HERE ') 900 CALL BORT('TABSUB - SUBSET NODE NOT IN TABLE D: '//NEMO) 901 CALL BORT('TABSUB - TOO MANY LIMBS ') END C----------------------------------------------------------------------- C----------------------------------------------------------------------- SUBROUTINE TRYBUMP(LUNIT,LUN,USR,I1,I2,IO,IRET) COMMON /USRINT/ NVAL(10),INV(15000,10),VAL(15000,10) COMMON /USRSTR/ NNOD,NCON,NODS(20),NODC(10),IVLS(10),KONS(10) REAL*8 USR(I1,I2),VAL C----------------------------------------------------------------------- C----------------------------------------------------------------------- C SEE IF THERE IS A DRP GROUP INVOLVED C ------------------------------------ NDRP = LSTJPB(NODS(1),LUN,'DRP') IF(NDRP.LE.0) RETURN C IF SO, CLEAN IT OUT, BUMP IT TO I2, AND TRY UFBRW AGAIN C ------------------------------------------------------- INVN = INVWIN(NDRP,LUN,1,NVAL(LUN)) VAL(INVN,LUN) = 0 JNVN = INVN+1 DO WHILE(NINT(VAL(JNVN,LUN)).GT.0) JNVN = JNVN+NINT(VAL(JNVN,LUN)) ENDDO DO KNVN=1,NVAL(LUN)-JNVN+1 INV(INVN+KNVN,LUN) = INV(JNVN+KNVN-1,LUN) VAL(INVN+KNVN,LUN) = VAL(JNVN+KNVN-1,LUN) ENDDO NVAL(LUN) = NVAL(LUN)-(JNVN-INVN-1) CALL USRTPL(LUN,INVN,I2) CALL UFBRW(LUN,USR,I1,I2,IO,IRET) RETURN 900 CALL BORT('TRYBUMP - ATTEMPT TO BUMP NON-ZERO REP FACTOR') END C---------------------------------------------------------------------- C---------------------------------------------------------------------- SUBROUTINE UFBINT(LUNIN,USR,I1,I2,IRET,STR) COMMON /MSGCWD/ NMSG(10),NSUB(10),MSUB(10),INODE(10),IDATE(10) COMMON /USRSTR/ NNOD,NCON,NODS(20),NODC(10),IVLS(10),KONS(10) COMMON /USRINT/ NVAL(10),INV(15000,10),VAL(15000,10) CHARACTER*(*) STR DIMENSION USR(I1,I2) REAL*8 USR,VAL DATA BMISS /10E10/ C---------------------------------------------------------------------- CFPP$ EXPAND (STATUS,UFBRW) C---------------------------------------------------------------------- IRET = 0 IF(I1.LE.0) RETURN IF(I2.LE.0) RETURN C CHECK THE FILE STATUS AND I-NODE AND PARSE OR RECALL THE STRING C --------------------------------------------------------------- LUNIT = ABS(LUNIN) CALL STATUS(LUNIT,LUN,IL,IM) IF(IL.EQ.0) GOTO 900 IF(IM.EQ.0) GOTO 901 IF(INODE(LUN).NE.INV(1,LUN)) GOTO 902 IO = MIN(MAX(0,IL),1) IF(LUNIT.NE.LUNIN) IO = 0 CALL STRING(STR,LUN,I1,IO) C INITIALIZE USR ARRAY PRECEEDING AN INPUT OPERATION C -------------------------------------------------- IF(IO.EQ.0) THEN DO J=1,I2 DO I=1,I1 USR(I,J) = BMISS ENDDO ENDDO ENDIF C CALL THE MNEMONIC READER/WRITER C ------------------------------- CALL UFBRW(LUN,USR,I1,I2,IO,IRET) C IF INCOMPLETE WRITE TRY TO INITIALIZE REPLICATION SEQUENCE OR RETURN C --------------------------------------------------------------------- IF(IO.EQ.1 .AND. IRET.NE.I2 .AND. IRET.GE.0) THEN CALL TRYBUMP(LUNIT,LUN,USR,I1,I2,IO,IRET) IF(IRET.NE.I2) PRINT*,STR IF(IRET.NE.I2) GOTO 903 ELSEIF(IRET.EQ.-1) THEN IRET = 0 ENDIF RETURN 900 CALL BORT('UFBINT - FILE IS CLOSED ') 901 CALL BORT('UFBINT - NO MESSAGE OPEN ') 902 CALL BORT('UFBINT - I-NODE MISMATCH ') 903 CALL BORT('UFBINT - INCOMPLETE WRITE ') END C---------------------------------------------------------------------- C---------------------------------------------------------------------- SUBROUTINE UFBRW(LUN,USR,I1,I2,IO,IRET) COMMON /TABLES/ MAXTAB,NTAB,TAG(15000),TYP(15000),KNT(15000), . JUMP(15000),LINK(15000),JMPB(15000), . IBT(15000),IRF(15000),ISC(15000), . ITP(15000),VALI(15000),KNTI(15000), . ISEQ(15000,2),JSEQ(15000) COMMON /USRINT/ NVAL(10),INV(15000,10),VAL(15000,10) COMMON /USRSTR/ NNOD,NCON,NODS(20),NODC(10),IVLS(10),KONS(10) CHARACTER*10 TAG CHARACTER*3 TYP REAL*8 USR(I1,I2),VAL C---------------------------------------------------------------------- CFPP$ EXPAND (CONWIN,DRSTPL,GETWIN,INVWIN,LSTRPS,NEWWIN,NXTWIN) C---------------------------------------------------------------------- IRET = 0 C LOOP OVER COND WINDOWS C ---------------------- INC1 = 1 INC2 = 1 1 CALL CONWIN(LUN,INC1,INC2,I2) IF(NNOD.EQ.0) THEN IRET = I2 RETURN ELSEIF(INC1.EQ.0) THEN RETURN ELSE DO I=1,NNOD IF(NODS(I).GT.0) THEN INS2 = INC1 CALL GETWIN(NODS(I),LUN,INS1,INS2) IF(INS1.EQ.0) RETURN GOTO 2 ENDIF ENDDO IRET = -1 RETURN ENDIF C LOOP OVER STORE NODES C --------------------- 2 IRET = IRET+1 C WRITE USER VALUES C ----------------- IF(IO.EQ.1 .AND. IRET.LE.I2) THEN DO I=1,NNOD IF(NODS(I).GT.0) THEN IF(USR(I,IRET).NE.10E10) THEN INVN = INVWIN(NODS(I),LUN,INS1,INS2) IF(INVN.EQ.0) THEN CALL DRSTPL(NODS(I),LUN,INS1,INS2,INVN) if(invn.eq.0) then iret = 0 return endif CALL NEWWIN(LUN,INC1,INC2) VAL(INVN,LUN) = USR(I,IRET) ELSEIF(LSTRPS(NODS(I),LUN).EQ.0) THEN VAL(INVN,LUN) = USR(I,IRET) ELSEIF(VAL(INVN,LUN).EQ.10E10) THEN VAL(INVN,LUN) = USR(I,IRET) ELSE CALL DRSTPL(NODS(I),LUN,INS1,INS2,INVN) if(invn.eq.0) then iret = 0 return endif CALL NEWWIN(LUN,INC1,INC2) VAL(INVN,LUN) = USR(I,IRET) ENDIF ENDIF ENDIF ENDDO ENDIF C READ USER VALUES C ---------------- IF(IO.EQ.0 .AND. IRET.LE.I2) THEN DO I=1,NNOD USR(I,IRET) = 10E10 IF(NODS(I).GT.0) THEN INVN = INVWIN(NODS(I),LUN,INS1,INS2) IF(INVN.GT.0) USR(I,IRET) = VAL(INVN,LUN) ENDIF ENDDO ENDIF C DECIDE WHAT TO DO NEXT C ---------------------- IF(IO.EQ.1.AND.IRET.EQ.I2) RETURN CALL NXTWIN(LUN,INS1,INS2) IF(INS1.GT.0 .AND. INS1.LT.INC2) GOTO 2 IF(NCON.GT.0) GOTO 1 RETURN END C---------------------------------------------------------------------- C UNPACK UP AN INTEGER C---------------------------------------------------------------------- SUBROUTINE UPB(NVAL,NBITS,IBAY,IBIT) COMMON /HRDWRD/ NBYTW,NBITW,NREV,IORD(8) DIMENSION IBAY(*) C---------------------------------------------------------------------- C---------------------------------------------------------------------- NWD = (IBIT)/NBITW+1 NBT = MOD(IBIT,NBITW) INT = ISHFT(IBAY(NWD),NBT) INT = ISHFT(INT,NBITS-NBITW) LBT = NBT+NBITS IF(LBT.GT.NBITW) JNT = IBAY(NWD+1) IF(LBT.GT.NBITW) INT = IOR(INT,ISHFT(JNT,LBT-2*NBITW)) IBIT = IBIT+NBITS NVAL = INT RETURN END C---------------------------------------------------------------------- C UNPACK UP AN INTEGER FOR SUBROUTINE RDTREE C---------------------------------------------------------------------- SUBROUTINE UPBB(INT,NBIT,MBIT,MBAY) COMMON /HRDWRD/ NBYTW,NBITW,NREV,IORD(8) DIMENSION MBAY(*) C---------------------------------------------------------------------- C---------------------------------------------------------------------- NWD = MBIT/NBITW + 1 NBT = MOD(MBIT,NBITW) LBT = NBT+NBIT IBA = MBAY(NWD) INT = ISHFT(ISHFT(IBA,NBT),NBIT-NBITW) IF(LBT.GT.NBITW) THEN IBA = MBAY(NWD+1) INT = IOR(INT,ISHFT(IBA,LBT-2*NBITW)) ENDIF RETURN END C---------------------------------------------------------------------- C COPY CHARACTERS FROM A BIT ARRAY C---------------------------------------------------------------------- SUBROUTINE UPC(CHR,NCHR,IBAY,IBIT) COMMON /HRDWRD/ NBYTW,NBITW,NREV,IORD(8) CHARACTER*(*) CHR CHARACTER*8 CVAL DIMENSION IBAY(*) EQUIVALENCE (CVAL,IVAL) C---------------------------------------------------------------------- C---------------------------------------------------------------------- LB = IORD(NBYTW) DO I=1,NCHR CALL UPB(IVAL,8,IBAY,IBIT) CHR(I:I) = CVAL(LB:LB) ENDDO RETURN END C----------------------------------------------------------------------- C----------------------------------------------------------------------- SUBROUTINE UPTDD(ID,LUN,IENT,IRET) COMMON /TABABD/ NTBA(0:10),NTBB(0:10),NTBD(0:10),MTAB(50,10), . IDNA(50,10,2),IDNB(250,10),IDND(250,10), . TABA(50,10),TABB(250,10),TABD(250,10) COMMON /DXTAB / MAXDX,IDXV,NXSTR(10),LDXA(10),LDXB(10),LDXD(10), . LD30(10),DXSTR(10) CHARACTER*600 TABD CHARACTER*128 TABB CHARACTER*128 TABA CHARACTER*56 DXSTR CHARACTER*1 cval (2) BYTE bval (2) EQUIVALENCE ( cval (1), bval (1) ) C----------------------------------------------------------------------- C----------------------------------------------------------------------- LDD = LDXD(IDXV+1)+1 C CHECK IF IENT IS IN BOUNDS C -------------------------- cval ( 1 ) = tabd ( id, lun ) ( ldd:ldd ) ndsc = bval ( 1 ) IF(IENT.EQ.0) THEN IRET = NDSC RETURN ELSEIF(IENT.LT.0 .OR. IENT.GT.NDSC) THEN CALL BORT('UPTDD - IENT OUT OF RANGE') ENDIF C RETURN THE DESCRIPTOR INDICATED BY IENT C --------------------------------------- IDSC = LDD+1 + (IENT-1)*2 cval ( 1 ) = tabd ( id, lun ) ( idsc:idsc ) cval ( 2 ) = tabd ( id, lun ) ( idsc+1:idsc+1 ) CALL MV_BTOI ( bval, 0, 2, .false., iret, jret ) RETURN END C----------------------------------------------------------------------- C----------------------------------------------------------------------- SUBROUTINE USRTPL(LUN,INVN,NBMP) PARAMETER (MAXINV=15000) PARAMETER (MAXTMP=1000) COMMON /MSGCWD/ NMSG(10),NSUB(10),MSUB(10),INODE(10),IDATE(10) COMMON /TABLES/ MAXTAB,NTAB,TAG(15000),TYP(15000),KNT(15000), . JUMP(15000),LINK(15000),JMPB(15000), . IBT(15000),IRF(15000),ISC(15000), . ITP(15000),VALI(15000),KNTI(15000), . ISEQ(15000,2),JSEQ(15000) COMMON /USRINT/ NVAL(10),INV(15000,10),VAL(15000,10) CHARACTER*10 TAG CHARACTER*3 TYP DIMENSION ITMP(MAXTMP),VTMP(MAXTMP) LOGICAL DRP,DRS,DRB,DRX REAL*8 VAL,VTMP C----------------------------------------------------------------------- C----------------------------------------------------------------------- IF(NBMP.LE.0) RETURN DRP = .FALSE. DRS = .FALSE. DRX = .FALSE. C SET UP A NODE EXPANSION C ----------------------- IF(INVN.EQ.1) THEN NODI = INODE(LUN) INV(1,LUN) = NODI NVAL(LUN) = 1 IF(NBMP.NE.1) GOTO 900 ELSEIF(INVN.GT.0 .AND. INVN.LE.NVAL(LUN)) THEN NODI = INV(INVN,LUN) DRP = TYP(NODI) .EQ. 'DRP' DRS = TYP(NODI) .EQ. 'DRS' DRB = TYP(NODI) .EQ. 'DRB' DRX = DRP .OR. DRS .OR. DRB IVAL = VAL(INVN,LUN) JVAL = 2**IBT(NODI)-1 VAL(INVN,LUN) = IVAL+NBMP IF(DRB.AND.NBMP.NE.1) GOTO 900 IF(.NOT.DRX ) GOTO 901 IF(IVAL.LT.0. ) GOTO 902 IF(IVAL+NBMP.GT.JVAL) GOTO 903 ELSE GOTO 904 ENDIF C RECALL A PRE-FAB NODE EXPANSION SEGMENT C --------------------------------------- NEWN = 0 N1 = ISEQ(NODI,1) N2 = ISEQ(NODI,2) IF(N1.EQ.0 ) GOTO 905 IF(N2-N1+1.GT.MAXTMP) GOTO 906 DO N=N1,N2 NEWN = NEWN+1 ITMP(NEWN) = JSEQ(N) VTMP(NEWN) = VALI(JSEQ(N)) if(vtmp(newn).gt.10e9) vtmp(newn) = 10e10 ENDDO C MOVE OLD NODES - STORE NEW ONES C ------------------------------- IF(NVAL(LUN)+NEWN*NBMP.GT.MAXINV) print*,'@:',nval(lun)+newn*nbmp IF(NVAL(LUN)+NEWN*NBMP.GT.MAXINV) GOTO 907 CDIR$ IVDEP DO J=NVAL(LUN),INVN+1,-1 INV(J+NEWN*NBMP,LUN) = INV(J,LUN) VAL(J+NEWN*NBMP,LUN) = VAL(J,LUN) ENDDO IF(DRP.OR.DRS) VTMP(1) = NEWN KNVN = INVN DO I=1,NBMP DO J=1,NEWN KNVN = KNVN+1 INV(KNVN,LUN) = ITMP(J) VAL(KNVN,LUN) = VTMP(J) ENDDO ENDDO C RESET POINTERS AND COUNTERS C --------------------------- NVAL(LUN) = NVAL(LUN) + NEWN*NBMP IF(DRX) THEN NODE = NODI INVR = INVN 4 NODE = JMPB(NODE) IF(NODE.GT.0) THEN IF(ITP(NODE).EQ.0) THEN DO INVR=INVR-1,1,-1 IF(INV(INVR,LUN).EQ.NODE) THEN VAL(INVR,LUN) = VAL(INVR,LUN)+NEWN*NBMP GOTO 4 ENDIF ENDDO GOTO 909 ELSE GOTO 4 ENDIF ENDIF ENDIF C NORMAL EXIT C ----------- RETURN C ERROR EXITS C ----------- 900 CALL BORT('USRTPL - NBMP <> 1 FOR : '//TAG(NODI)) 901 CALL BORT('USRTPL - NODE NOT SUB,DRP,DRS : '//TAG(NODI)) 902 CALL BORT('USRTPL - NEGATIVE REP FACTOR : '//TAG(NODI)) 903 CALL BORT('USRTPL - REP FACTOR OVERFLOW : '//TAG(NODI)) 904 CALL BORT('USRTPL - INVENTORY INDEX OUT OF BOUNDS ') 905 CALL BORT('USRTPL - UNSET EXPANSION SEG : '//TAG(NODI)) 906 CALL BORT('USRTPL - TEMP ARRAY OVERFLOW : '//TAG(NODI)) 907 CALL BORT('USRTPL - INVENTORY OVERFLOW : '//TAG(NODI)) 908 CALL BORT('USRTPL - TPL CACHE OVERFLOW : '//TAG(NODI)) 909 CALL BORT('USRTPL - BAD BACKUP STRATEGY : '//TAG(NODI)) END C---------------------------------------------------------------------- C REAL NUMBER FROM A STRING C---------------------------------------------------------------------- FUNCTION VALS(STR) CHARACTER*(*) STR CHARACTER*99 BSTR CHARACTER*8 FMT data noinline /0/ C---------------------------------------------------------------------- C---------------------------------------------------------------------- LENS = LEN(STR) IF(LENS.GT.99) CALL BORT('VALS - ARG TOO LONG') BSTR(1:LENS) = STR RJ = RJUST(BSTR(1:LENS)) WRITE(FMT,'(''(F'',I2,''.0)'')') LENS READ(BSTR,FMT,ERR=900) VAL VALS = VAL RETURN 900 VALS = 10E10 RETURN END C---------------------------------------------------------------------- C----------------------------------------------------------------------- SUBROUTINE WRDLEN COMMON /HRDWRD/ NBYTW,NBITW,NREV,IORD(8) COMMON /QUIET / IPRT CHARACTER*8 CINT,DINT EQUIVALENCE (CINT,INT) EQUIVALENCE (DINT,JNT) LOGICAL PRINT C----------------------------------------------------------------------- C----------------------------------------------------------------------- PRINT = NBYTW.EQ.0 .AND. IPRT.EQ.1 C COUNT THE BITS IN A WORD - MAX 64 ALLOWED C ----------------------------------------- INT = 1 DO I=1,65 INT = ISHFT(INT,1) IF(INT.EQ.0) GOTO 10 ENDDO 10 IF(I.GE.65) GOTO 900 IF(MOD(I,8).NE.0) GOTO 901 NBITW = I NBYTW = I/8 C INDEX THE BYTE STORAGE ORDER - HIGH BYTE TO LOW BYTE C ----------------------------------------------------- JNT = 0 DO I=1,NBYTW INT = ISHFT(1,(NBYTW-I)*8) DO J=1,NBYTW IF(CINT(J:J).NE.DINT(J:J)) GOTO 20 ENDDO 20 IF(J.GT.NBYTW) GOTO 902 IORD(I) = J ENDDO C SET THE NOREVERSE FLAG - 0=NOREVERSE;1=REVERSE C ---------------------------------------------- NREV = 0 DO I=1,NBYTW IF(IORD(I).NE.I) NREV = 1 ENDDO C SHOW SOME RESULTS C ----------------- IF(PRINT) THEN PRINT100,NBYTW,NBITW,NREV,(IORD(I),I=1,NBYTW) ENDIF 100 FORMAT(' WRDLEN:NBYTW=',I1,' NBITW=',I2,' IREV=',I1,' IORD=',8I1) RETURN 900 CALL BORT('WRDLEN - A WORD IS MORE THAN 64 BITS') 901 CALL BORT('WRDLEN - A WORD IS NOT MADE OF BYTES') 902 CALL BORT('WRDLEN - BYTE ORDER CHECKING MISTAKE') END C----------------------------------------------------------------------- C----------------------------------------------------------------------- SUBROUTINE WTSTAT(LUNIT,LUN,IL,IM) COMMON /STBFR/ IOLUN(10),IOMSG(10) C----------------------------------------------------------------------- C----------------------------------------------------------------------- C CHECK ON THE ARGUMENTS C ---------------------- IF(LUNIT.LE.0) GOTO 900 IF(LUN .LE.0) GOTO 901 IF(IL.LT.-1 .OR. IL.GT.1) GOTO 902 IF(IM.LT. 0 .OR. IL.GT.1) GOTO 903 C CHECK ON LUNIT-LUN COMBINATION C ------------------------------ IF(ABS(IOLUN(LUN)).NE.LUNIT) THEN IF(IOLUN(LUN).NE.0) GOTO 905 ENDIF C RESET THE FILE STATUSES C ----------------------- IF(IL.NE.0) THEN IOLUN(LUN) = SIGN(LUNIT,IL) IOMSG(LUN) = IM ELSE IOLUN(LUN) = 0 IOMSG(LUN) = 0 ENDIF RETURN 900 CALL BORT('WTSTAT - BAD LUNIT ') 901 CALL BORT('WTSTAT - BAD LUN ') 902 CALL BORT('WTSTAT - BAD IL ') 903 CALL BORT('WTSTAT - BAD IM ') 905 CALL BORT('WTSTAT - ATTEMPT TO REDEFINE EXISTING FILE UNIT ') END