C Copyright(C) 1999-2021 National Technology & Engineering Solutions C of Sandia, LLC (NTESS). Under the terms of Contract DE-NA0003525 with C NTESS, the U.S. Government retains certain rights in this software. C C See packages/seacas/LICENSE for details SUBROUTINE RDFSQ (MP, ML, MS, MR, MSNAP, MSC, MA, IUNIT, IDUMP, N, & IPOINT, COOR, IPBOUN, ILINE, LTYPE, NINT, FACTOR, LCON, ILBOUN, & ISBOUN, ISIDE, NLPS, IFLINE, ILLIST, IBARST, JMAT, JCENT, NLPB, & JFLINE, JLLIST, IREGN, IMAT, NSPR, IFSIDE, ISLIST, IRPB, IPBF, & NPPF, IFPB, LISTPB, ILBF, NLPF, IFLB, LISTLB, ISBF, NSPF, IFSB, & LISTSB, ATTRIB, LINKP, LINKL, LINKS, LINKB, LINKR, LINKM, & LINKSC, LINKPB, LINKLB, LINKSB, IHOLDP, IHOLDL, IHOLDS, IHOLDB, & IHOLDR, IHOLDM, IHOLD1, IHOLD2, IHOLD3, IWTPBF, IWTLBF, IWTSBF, & RSIZE, IFHOLE, NHPR, IHLIST, IRGFLG, ISCHM, SCHEME, NUMBER, & DEFSCH, DEFSIZ, TITLE, OPTIM, MERGE, THREE, EIGHT, NINE, & SNAP, SNAPDX, NSNAP, RATIO, NOROOM, EXODUSII) C*********************************************************************** C SUBROUTINE RDFSQ = READS AND/OR MERGES FASTQ CARD FILE(S) C*********************************************************************** C SUBROUTINE CALLED BY: C FASTQ = A PROGRAM TO QUICKLY PREPARE FASTQ INPUT C*********************************************************************** C VARIABLES USED: C TITLE = MESH TITLE C IHOLDP = AN ARRAY TO HOLD THE POINTS DURING RENUMBERING C IHOLDL = AN ARRAY TO HOLD THE LINES DURING RENUMBERING C IHOLDS = AN ARRAY TO HOLD THE SIDES DURING RENUMBERING C IHOLDR = AN ARRAY TO HOLD THE REGIONS DURING RENUMBERING C DUMB = DUMMY VARIABLE WHERE THE DATA IS READ IN C OPTIM = .TRUE. IF THE MESH IS TO BE OPTIMIZED C MERGE = .TRUE. IF THE DATA IS TO BE MERGED WITH EXISTING DATA C NOROOM = .TRUE. IF THE AMOUNT OF DATA EXCEEDS DIMENSIONED LIMITS C NODATA = .TRUE. IF NO DATA HAS BEEN READ FROM THE FILE C*********************************************************************** PARAMETER (NIN = 1000) DIMENSION IPOINT(MP), COOR(2, MP), IPBOUN(MP) DIMENSION ILINE(ML), LTYPE(ML), NINT(ML), FACTOR(ML), LCON(3, ML) DIMENSION ILBOUN(ML), ISBOUN(ML) DIMENSION ISIDE(MS), NLPS(MS), IFLINE(MS), ILLIST(MS*3) DIMENSION IBARST(MS), JMAT(MS), JCENT(MS), NLPB(MS), JFLINE(MS) DIMENSION JLLIST(3*MS) DIMENSION IREGN(MR), IMAT(MR), NSPR(MR), IFSIDE(MR), ISLIST(MR*4) DIMENSION IRPB(MR), ISCHM(MSC), SCHEME(MSC), RSIZE(MR) DIMENSION IPBF(MP), NPPF(MP), IFPB(MP), LISTPB(2, MP) DIMENSION ILBF(ML), NLPF(ML), IFLB(ML), LISTLB(2, ML) DIMENSION ISBF(ML), NSPF(ML), IFSB(ML), LISTSB(2, ML) DIMENSION IWTPBF(3, MP), IWTLBF(3, ML), IWTSBF(3, ML) DIMENSION ATTRIB((MR + MS)*MA) DIMENSION LINKP(2, MP), LINKL(2, ML), LINKS(2, MS), LINKB(2, MS) DIMENSION LINKR(2, MR), LINKM(2, (MS + MR)), LINKSC(2, MR) DIMENSION LINKPB(2, MP), LINKLB(2, ML), LINKSB(2, ML) DIMENSION IFHOLE(MR), NHPR(MR), IHLIST(MR*2), IRGFLG(MR) DIMENSION NUMBER(MSC) DIMENSION IHOLDP(2, MP), IHOLDL(2, ML), IHOLDS(2, MS) DIMENSION IHOLDB(2, MS), IHOLDR(2, MR), IHOLDM(2, (MS + MR)) DIMENSION IHOLD1(2, MP), IHOLD2(2, ML), IHOLD3(2, ML) DIMENSION N(29), NOLD(29), III(1) DIMENSION KIN(NIN), CIN(NIN), IIN(NIN), RIN(NIN) DIMENSION SNAPDX(2, MSNAP), NSNAP(2) CHARACTER*72 SCHEME, DEFSCH CHARACTER*72 TITLE, HOLD, NUMBER*80, CIN*72 LOGICAL OPTIM, MERGE, NEWNUM, NOROOM, ADDOLD, DOLINK, ERR LOGICAL NODATA, ADDLNK, THREE, EIGHT, NINE, SIDEOK, SNAP LOGICAL EXODUSII C SET UP THE INITIALIZATION OF VARIABLES DO 100 I = 1, 29 NOLD(I) = N(I) 100 CONTINUE LHOLD = 0 NHOLDP = 0 NHOLDL = 0 NHOLDS = 0 NHOLDB = 0 NHOLDR = 0 NHOLDM = 0 NHOLD1 = 0 NHOLD2 = 0 NHOLD3 = 0 THREE = .FALSE. EIGHT = .FALSE. NINE = .FALSE. OPTIM = .FALSE. NOROOM = .FALSE. ADDOLD = .TRUE. NODATA = .TRUE. ADDLNK = .TRUE. DEFSCH = 'M' C READ THE INPUT CARDS AND SORT AS NEEDED DO 130 I = 1, MP + 2*ML + MS + 2*MR CALL FREFLD (IUNIT, IDUMP, ' ', NIN, IOSTAT, IFOUND, & KIN, CIN, IIN, RIN) C CHECK FOR THE END OF THE FILE OR FOR AN ERROR IF (IOSTAT .LT. 0) GO TO 140 C INPUT THE TITLE IF (CIN(1)(1:5) .EQ. 'TITLE') THEN NODATA = .FALSE. IF (MERGE) THEN CALL STRLNG (TITLE, LEN) IF (LEN .LE. 70) THEN LHOLD = LEN TITLE(LEN + 1:LEN + 1) = ':' CALL GETINP (IUNIT, IDUMP, ' ', HOLD, IOSTAT) CALL STRCUT (HOLD) LEND = 71 - LEN TITLE(LEN + 2:72) = HOLD(1:LEND) END IF ELSE CALL GETINP (IUNIT, IDUMP, ' ', TITLE, IOSTAT) END IF CALL STRCUT (TITLE) CALL STRLNG (TITLE, LEN) C INPUT A POINT INTO THE DATABASE ELSE IF (CIN(1)(1:5) .EQ. 'POINT') THEN NODATA = .FALSE. JJ = IIN(2) IF ((JJ .LE. 0) .OR. (JJ .GE. 10000)) THEN WRITE(*, 10000) JJ GO TO 120 END IF CALL INPOIN (MP, N(1), N(18), JJ, RIN(3), RIN(4), NHOLDP, & IHOLDP, IPOINT, COOR, IPBOUN, LINKP, MERGE, NOROOM) IF (NOROOM) GO TO 310 C INPUT A LINE INTO THE DATABASE ELSE IF (CIN(1)(1:5) .EQ. 'LINE ')THEN NODATA = .FALSE. JJ = IIN(2) IF ((JJ .LE. 0) .OR. (JJ .GE. 10000)) THEN WRITE(*, 10010)JJ GO TO 120 ELSE IF (IFOUND .LT. 5) THEN WRITE(*, 10020) JJ GO TO 120 END IF IF ((CIN(3)(1:4) .EQ. 'STR ') .OR. & (CIN(3)(1:4) .EQ. ' ')) THEN LTYP = 1 ELSE IF (CIN(3)(1:4) .EQ. 'CIRC') THEN LTYP = 3 ELSE IF (CIN(3)(1:4) .EQ. 'CIRM') THEN LTYP = 4 ELSE IF (CIN(3)(1:4) .EQ. 'CIRR') THEN LTYP = 6 ELSE IF (CIN(3)(1:4) .EQ. 'PARA') THEN LTYP = 5 ELSE IF (CIN(3)(1:4) .EQ. 'CORN') THEN LTYP = 2 ELSE IF (CIN(3)(1:4) .EQ. 'ELIP') THEN LTYP = 7 ELSE IF (CIN(3)(1:4) .EQ. 'ELPR') THEN LTYP = 8 ELSE LTYP = 1 WRITE(*, 10030) CIN(3)(1:4), JJ END IF CALL INLINE (ML, N(2), N(19), JJ, LTYP, IIN(4), IIN(5), & IIN(6), IIN(7), RIN(8), NHOLDL, IHOLDL, ILINE, LTYPE, & NINT, FACTOR, LCON, ILBOUN, ISBOUN, LINKL, MERGE, NOROOM) IF (NOROOM) GO TO 310 C INPUT A SIDE INTO THE DATABASE ELSE IF (CIN(1)(1:5) .EQ. 'SIDE ') THEN NODATA = .FALSE. JJ = IIN(2) IF ((JJ .LE. 0) .OR. (JJ .GE. 10000)) THEN WRITE(*, 10040) JJ GO TO 120 ELSE IF (IFOUND .LT. 3) THEN WRITE(*, 10050) JJ GO TO 120 END IF CALL INSIDE (MS, N(3), N(4), N(20), JJ, IIN(3), IFOUND - 2, & ISIDE, NLPS, IFLINE, ILLIST, LINKS, NHOLDS, IHOLDS, & MERGE, NOROOM) IF (NOROOM) GO TO 310 C INPUT A BAR SET INTO THE DATABASE ELSE IF (CIN(1)(1:6) .EQ. 'BARSET') THEN NODATA = .FALSE. JJ = IIN(2) IF ((JJ .LE. 0) .OR. (JJ .GE. 10000)) THEN WRITE(*, 10040) JJ GO TO 120 ELSE IF (IFOUND .LT. 5) THEN WRITE(*, 10050) JJ GO TO 120 END IF CALL INBRST (MS, MR, N(5), N(6), N(21), N(23), JJ, IIN(3), & IIN(4), IIN(5), IFOUND - 4, IBARST, JMAT, JCENT, NLPB, & JFLINE, JLLIST, LINKB, LINKM, NHOLDM, IHOLDM, NHOLDB, & IHOLDB, MERGE, NOROOM) IF (NOROOM) GO TO 310 C INPUT A REGION INTO THE DATABASE ELSE IF (CIN(1)(1:6) .EQ. 'REGION') THEN NODATA = .FALSE. JJ = IIN(2) IF ((JJ .LE. 0) .OR. (JJ .GE. 10000)) THEN WRITE(*, 10060) JJ GO TO 120 ELSE IF (IFOUND .LT. 4) THEN WRITE(*, 10080) JJ GO TO 120 END IF CALL INREGN (MS, MR, N(7), N(8), N(22), N(23), JJ, IIN(3), & IIN(4), IFOUND - 3, IREGN, IMAT, NSPR, IFSIDE, ISLIST, & LINKR, LINKM, NHOLDR, IHOLDR, NHOLDM, IHOLDM, IRGFLG, & MERGE, NOROOM) ADDLNK = .FALSE. CALL LTSORT (MR, LINKR, IIN(2), JJPNTR, ADDLNK) ADDLNK = .TRUE. RSIZE(JJPNTR) = 0. NHPR(JJPNTR) = 0 IF (NOROOM) GO TO 310 C INPUT A GROUP INTO THE DATABASE ELSE IF (CIN(1)(1:6) .EQ. 'GROUP ') THEN NODATA = .FALSE. JJ = IIN(2) IF ((JJ .LE. 0) .OR. (JJ .GE. 10000)) THEN WRITE(*, 10060) JJ GO TO 120 ELSE IF (IFOUND .LT. 3) THEN WRITE(*, 10080) JJ GO TO 120 END IF CALL INGRPN (MS, MR, N(7), N(8), N(22), JJ, IIN(3), & IFOUND - 2, IREGN, NSPR, IFSIDE, ISLIST, LINKR, NHOLDR, & IHOLDR, IRGFLG, MERGE, NOROOM) IF (NOROOM) GO TO 310 C INPUT A REGION'S HOLES INTO THE DATABASE ELSE IF (CIN(1)(1:6) .EQ. 'HOLE ') THEN NODATA = .FALSE. JJ = IIN(2) ADDLNK = .FALSE. CALL LTSORT (MR, LINKR, JJ, JJPNTR, ADDLNK) IF (MERGE .AND. JJPNTR .GT. 0) THEN CALL LTSORT (MR, IHOLDR, JJ, JJNEW, ADDLNK) IF (JJNEW .GT. 0) THEN CALL LTSORT (MR, LINKR, JJNEW, JJPNTR, ADDLNK) END IF END IF ADDLNK = .TRUE. IF (JJPNTR .LE. 0) THEN WRITE(*, 10090) JJ GO TO 120 ELSE IF (IFOUND .LT. 3) THEN WRITE(*, 10100) JJ GO TO 120 END IF CALL INHOLE (MR, N(7), N(29), JJPNTR, IIN(3), IFOUND - 2, & IFHOLE, NHPR, IHLIST, MERGE, NOROOM) IF (NOROOM) GO TO 310 C INPUT A SCHEME INTO THE DATABASE ELSE IF (CIN(1)(1:6) .EQ. 'SCHEME') THEN NODATA = .FALSE. JJ = IIN(2) IF (JJ .GE. 10000) THEN WRITE(*, 10110) JJ GO TO 120 ELSE IF (IFOUND .LT. 3) THEN IF (JJ .EQ. 0) THEN WRITE(*, 10120) ELSE WRITE(*, 10130) JJ END IF GO TO 120 END IF DOLINK = .FALSE. NOLD10 = N(10) NOLD24 = N(24) CALL INSCHM (MR, MSC, N(10), N(24), JJ, CIN(3), ISCHM, & SCHEME, LINKSC, DEFSCH, NOROOM, DOLINK) IF (NOROOM) THEN N(10) = NOLD10 N(24) = NOLD24 CALL MESSAGE('************************************') CALL MESSAGE('NOT ENOUGH ROOM FOR SCHEME CARD') CALL MESSAGE('NO DYNAMIC DIMENSIONING INCREASES') CALL MESSAGE('AVAILABLE FOR CHARACTER STRINGS') CALL MESSAGE('SCHEME CARD IS THUS IGNORED') CALL MESSAGE('************************************') END IF C INPUT INTERVALS FOR SIDES OR LINES ELSE IF (CIN(1)(1:3) .EQ. 'INT') THEN NODATA = .FALSE. JJ = IIN(3) IF (IFOUND .LT. 3) THEN IF (JJ .LT. 0) THEN WRITE(*, 10140) -JJ ELSE WRITE(*, 10150) JJ END IF GO TO 120 END IF ADDLNK = .FALSE. CALL ININTR (ML, MS, IFOUND - 2, IIN(2), IIN(3), N(19), & N(20), NINT, NLPS, IFLINE, ILLIST, LINKL, LINKS, ADDLNK) ADDLNK = .TRUE. C INPUT FACTORS FOR SIDES OR LINES ELSE IF (CIN(1)(1:3) .EQ. 'FAC') THEN NODATA = .FALSE. JJ = IIN(3) IF (IFOUND .LT. 3) THEN IF (JJ .LT. 0) THEN WRITE(*, 10160) -JJ ELSE WRITE(*, 10170) JJ END IF GO TO 120 END IF ADDLNK = .FALSE. CALL INFACT (ML, MS, IFOUND - 2, RIN(2), IIN(3), N(19), & N(20), FACTOR, NLPS, IFLINE, ILLIST, LINKL, LINKS, & ADDLNK) ADDLNK = .TRUE. C INPUT A REGION'S INTERVAL SIZE INTO THE DATABASE ELSE IF (CIN(1)(1:5) .EQ. 'SIZE ') THEN NODATA = .FALSE. IF (IFOUND .LT. 3) THEN DEFSIZ = AMAX1(RIN(2), 0.) ELSE ADDLNK = .FALSE. DO 110 IRSZ = 3, IFOUND CALL LTSORT (MR, LINKR, IIN(IRSZ), JJ, ADDLNK) IF (JJ .GT. 0) THEN RSIZE(JJ) = AMAX1(RIN(2), 0.) ELSE WRITE(*, 10070) IIN(IRSZ) END IF 110 CONTINUE ADDLNK = .TRUE. END IF C INPUT A BODY DEFINITION INTO THE DATABASE ELSE IF (CIN(1)(1:4) .EQ. 'BODY') THEN NODATA = .FALSE. IF (IFOUND .GT. 1) THEN CALL INBODY (MR, N(9), IIN(2), IFOUND - 1, IRPB, ADDOLD, & NOROOM) IF (NOROOM) GO TO 310 END IF C INPUT A POINT BOUNDARY INTO THE DATABASE ELSE IF (CIN(1)(1:6) .EQ. 'POINBC') THEN IF (IFOUND .LT. 3) THEN WRITE(*, 10200) IIN(2) GO TO 120 END IF NODATA = .FALSE. CALL INBOUN (MP, IIN(2), IFOUND - 2, IIN(3), N(25), N(11), & N(12), NOLD(11), MERGE, NOROOM, NEWNUM, NHOLD1, IHOLD1, & IPBF, NPPF, IFPB, LISTPB, LINKPB, IWTPBF, JHOLD, ADDOLD) IF (NOROOM) GO TO 310 IF (NEWNUM) THEN ADDLNK = .FALSE. CALL LTSORT (MP, IHOLD1, JHOLD, IPNTR, ADDLNK) WRITE(*, 10210)JHOLD, IPNTR ADDLNK = .TRUE. END IF C INPUT A LINE BOUNDARY INTO THE DATABASE ELSE IF ((CIN(1)(1:6) .EQ. 'NODEBC') .OR. & (CIN(1)(1:6) .EQ. 'LINEBC')) THEN IF (IFOUND .LT. 3) THEN WRITE(*, 10220) IIN(2) GO TO 120 END IF NODATA = .FALSE. CALL INBOUN (ML, IIN(2), IFOUND - 2, IIN(3), N(26), N(13), & N(14), NOLD(13), MERGE, NOROOM, NEWNUM, NHOLD2, IHOLD2, & ILBF, NLPF, IFLB, LISTLB, LINKLB, IWTLBF, JHOLD, ADDOLD) IF (NOROOM) GO TO 310 IF (NEWNUM) THEN ADDLNK = .FALSE. CALL LTSORT (ML, IHOLD2, JHOLD, IPNTR, ADDLNK) WRITE(*, 10230)JHOLD, IPNTR ADDLNK = .TRUE. END IF C INPUT A SIDE BOUNDARY INTO THE DATABASE ELSE IF ((CIN(1)(1:6) .EQ. 'ELEMBC') .OR. & (CIN(1)(1:6) .EQ. 'SIDEBC')) THEN IF (IFOUND .LT. 3) THEN WRITE(*, 10240) IIN(2) GO TO 120 END IF NODATA = .FALSE. CALL INBOUN (ML, IIN(2), IFOUND - 2, IIN(3), N(27), N(15), & N(16), NOLD(15), MERGE, NOROOM, NEWNUM, NHOLD3, IHOLD3, & ISBF, NSPF, IFSB, LISTSB, LINKSB, IWTSBF, JHOLD, ADDOLD) IF (NOROOM) GO TO 310 IF (NEWNUM) THEN ADDLNK = .FALSE. CALL LTSORT (ML, IHOLD3, JHOLD, IPNTR, ADDLNK) WRITE(*, 10250)JHOLD, IPNTR ADDLNK = .TRUE. END IF C INPUT A FLAG WEIGHTING INTO THE DATABASE ELSE IF (CIN(1)(1:6) .EQ. 'WEIGHT') THEN ADDLNK = .FALSE. NODATA = .FALSE. C GET THE FLAG TYPE IF (CIN(2)(1:1) .EQ. 'P') THEN CALL LTSORT (MP, LINKPB, IIN(3), JJ, ADDLNK) IF (JJ .GT. 0) THEN IWTPBF(1, JJ) = IIN(4) IWTPBF(2, JJ) = IIN(5) IWTPBF(3, JJ) = 0 ELSE WRITE(*, 10260) 'POINT', IIN(3) END IF ELSE IF (CIN(2)(1:1) .EQ. 'L') THEN CALL LTSORT (ML, LINKLB, IIN(3), JJ, ADDLNK) IF (JJ .GT. 0) THEN IWTLBF(1, JJ) = IIN(4) IWTLBF(2, JJ) = IIN(5) IWTLBF(3, JJ) = IIN(6) ELSE WRITE(*, 10270) 'LINE', IIN(3) END IF ELSE IF (CIN(2)(1:1) .EQ. 'S') THEN CALL LTSORT (ML, LINKSB, IIN(3), JJ, ADDLNK) IF (JJ .GT. 0) THEN IWTSBF(1, JJ) = IIN(4) IWTSBF(2, JJ) = IIN(5) IWTSBF(3, JJ) = IIN(6) ELSE WRITE(*, 10270) 'SIDE', IIN(3) END IF ELSE C NO FLAG TYPE HAS BEEN RECOGNIZED WRITE(*, 10280) CIN(2)(1:5) END IF ADDLNK = .TRUE. C FLAG THE BANDWIDTH OPTIMIZATION ROUTINES ON, AND READ A RENUM CARD ELSE IF (CIN(1)(1:5) .EQ. 'RENUM') THEN NODATA = .FALSE. OPTIM = .TRUE. IF (IFOUND .GT. 2) THEN HOLD = CIN(2) IDUM = IFOUND - 2 CALL INRENM (MSC, N(28), HOLD, RIN(3), IIN(3), IDUM, & NUMBER, NOROOM) IF (NOROOM) THEN CALL MESSAGE('************************************') CALL MESSAGE('NOT ENOUGH ROOM FOR RENUMBERING CARD') CALL MESSAGE('NO DYNAMIC DIMENSIONING INCREASES') CALL MESSAGE('AVAILABLE FOR CHARACTER STRINGS') CALL MESSAGE('RENUMBERING CARD IS THUS IGNORED') CALL MESSAGE('************************************') END IF ELSE IF (IFOUND .EQ. 2) THEN CALL MESSAGE('RENUM CARD READ WITHOUT ANY DATA') CALL MESSAGE('DEFAULT RENUM PROCESSING WILL BE USED') END IF C Write Database in exodusII format ELSE IF (CIN(1)(1:2) .EQ. 'X2') THEN NODATA = .FALSE. EXODUSII = .TRUE. C Write Database in exodusI/genesis format ELSE IF (CIN(1)(1:2) .EQ. 'X1') THEN NODATA = .FALSE. EXODUSII = .FALSE. C FLAG THE GENERATION OF THREE NODE ELEMENTS ELSE IF (CIN(1)(1:5) .EQ. 'THREE') THEN NODATA = .FALSE. THREE = .TRUE. C FLAG THE GENERATION OF EIGHT NODE ELEMENTS ELSE IF (CIN(1)(1:5) .EQ. 'EIGHT') THEN NODATA = .FALSE. EIGHT = .TRUE. NINE = .FALSE. C FLAG THE GENERATION OF NINE NODE ELEMENTS ELSE IF (CIN(1)(1:4) .EQ. 'NINE') THEN NODATA = .FALSE. NINE = .TRUE. EIGHT = .FALSE. C INPUT SNAP-TO-GRID FLAG ELSE IF (CIN(1)(1:4) .EQ. 'SNAP') THEN NODATA = .FALSE. SNAP = CIN(2)(1:2) .EQ. 'ON' C INPUT X-GRID LINES ELSE IF (CIN(1)(1:4) .EQ. 'XGRI') THEN IF (IFOUND .LT. 2) THEN WRITE(*, 10290) 'XGRID' GO TO 120 END IF NODATA = .FALSE. CALL INGRID (MSNAP, SNAPDX, NSNAP, 1, RIN(2), IFOUND - 1, & ERR) C INPUT Y-GRID LINES ELSE IF (CIN(1)(1:4) .EQ. 'YGRI') THEN IF (IFOUND .LT. 2) THEN WRITE(*, 10290) 'YGRID' GO TO 120 END IF NODATA = .FALSE. CALL INGRID (MSNAP, SNAPDX, NSNAP, 2, RIN(2), IFOUND - 1, & ERR) C END OF DATA ELSE IF (CIN(1)(1:4) .EQ. 'EXIT') THEN NODATA = .FALSE. GO TO 150 END IF 120 CONTINUE 130 CONTINUE 140 CONTINUE CALL MESSAGE('FILE END ENCOUNTERED BEFORE -EXIT- CARD WAS FOUND') CALL MESSAGE('POSSIBLE PROBLEM IN FILE') C RENUMBER THE CARDS IF MERGING 150 CONTINUE ADDLNK = .FALSE. IF (MERGE) THEN C RENUMBER THE POINTS CONTAINED IN THE LINE, AND POINT BOUNDARY CARDS DO 170 I = NOLD(2) + 1, N(2) DO 160 J = 1, 3 CALL LTSORT (MP, IHOLDP, LCON(J, I), IPNTR, ADDLNK) IF ((LCON(J, I) .LE. NHOLDP) .AND. (IPNTR .GT. 0)) & LCON(J, I) = IPNTR 160 CONTINUE 170 CONTINUE DO 180 I = NOLD(12) + 1, N(12) CALL LTSORT (MP, IHOLDP, LISTPB(1, I), IPNTR, ADDLNK) IF ((LISTPB(1, I) .LE. NHOLDP) .AND. (IPNTR .GT. 0)) & LISTPB(1, I) = IPNTR 180 CONTINUE C RENUMBER THE LINES CONTAINED IN THE SIDE, BAR SET, REGION, C LINE BOUNDARY, AND SIDE BOUNDARY CARDS DO 190 I = NOLD(4) + 1, N(4) CALL LTSORT (ML, IHOLDL, ILLIST(I), IPNTR, ADDLNK) IF ((ILLIST(I) .LE. NHOLDL) .AND. (IPNTR .GT. 0)) & ILLIST(I) = IPNTR 190 CONTINUE DO 200 I = NOLD(6) + 1, N(6) CALL LTSORT (ML, IHOLDL, JLLIST(I), IPNTR, ADDLNK) IF ((JLLIST(I) .LE. NHOLDL) .AND. (IPNTR .GT. 0)) & JLLIST(I) = IPNTR 200 CONTINUE DO 210 I = NOLD(8) + 1, N(8) IF (ISLIST(I) .LT. 0)THEN KK = ABS(ISLIST(I)) CALL LTSORT (ML, IHOLDL, KK, IPNTR, ADDLNK) IF ((KK .LE. NHOLDL) .AND. (IPNTR .GT. 0)) & ISLIST(I) = -IPNTR END IF 210 CONTINUE DO 220 I = NOLD(14) + 1, N(14) CALL LTSORT (ML, IHOLDL, LISTLB(1, I), IPNTR, ADDLNK) IF ((LISTLB(1, I) .LE. NHOLDL) .AND. (IPNTR .GT. 0)) & LISTLB(1, I) = IPNTR 220 CONTINUE DO 230 I = NOLD(16) + 1, N(16) CALL LTSORT (ML, IHOLDL, LISTSB(1, I), IPNTR, ADDLNK) IF ((LISTSB(1, I) .LE. NHOLDL) .AND. (IPNTR .GT. 0)) & LISTSB(1, I) = IPNTR 230 CONTINUE C RENUMBER THE SIDES CONTAINED IN THE REGION CARDS DO 240 I = NOLD(8) + 1, N(8) IF (ISLIST(I) .GT. 0) THEN CALL LTSORT (MS, IHOLDS, ISLIST(I), IPNTR, ADDLNK) IF ((ISLIST(I) .LE. NHOLDS) .AND. (IPNTR .GT. 0)) & ISLIST(I) = IPNTR END IF 240 CONTINUE C RENUMBER THE REGIONS CONTAINED IN THE HOLE CARDS DO 250 I = NOLD(29) + 1, N(29) IF (IHLIST(I) .GT. 0) THEN CALL LTSORT (MR, IHOLDR, IHLIST(I), IPNTR, ADDLNK) IF ((IHLIST(I) .LE. NHOLDR) .AND. (IPNTR .GT. 0)) & IHLIST(I) = IPNTR END IF 250 CONTINUE C RENUMBER THE BAR SETS AND REGIONS CONTAINED IN THE BODY, C AND THE REGIONS CONTAINED IN THE SCHEME CARDS DO 260 I = NOLD(9) + 1, N(9) IF (IRPB(I) .GT. 0) THEN CALL LTSORT (MR, IHOLDR, IRPB(I), IPNTR, ADDLNK) IF ((IRPB(I) .LE. NHOLDR) .AND. (IPNTR .GT. 0)) & IRPB(I) = IPNTR ELSE IF (IRPB(I) .LT. 0) THEN CALL LTSORT (MS, IHOLDB, IABS(IRPB(I)), IPNTR, ADDLNK) IF ((IABS(IRPB(I)) .LE. NHOLDB) .AND. (IPNTR .GT. 0)) & IRPB(I) = -IPNTR END IF 260 CONTINUE DO 270 I = NOLD(10) + 1, N(10) CALL LTSORT (MR, IHOLDR, ISCHM(I), IPNTR, ADDLNK) IF ((ISCHM(I) .LE. NHOLDR) .AND. (IPNTR .GT. 0)) & ISCHM(I) = IPNTR 270 CONTINUE END IF C LINK THE SCHEME CARDS ADDLNK = .TRUE. DO 280 I = NOLD(10) + 1, N(10) IF (ISCHM(I) .GT. N(24)) N(24) = ISCHM(I) CALL LTSORT (MR, LINKSC, ISCHM(I), I, ADDLNK) 280 CONTINUE C LINK UP THE POINTS AND LINES TO THEIR ASSOCIATED FLAGS SIDEOK = .FALSE. CALL LINKBC (MP, MS, NOLD(11) + 1, N(11), N(1), N(25), N(11), & N(12), N(20), IPBF, IFPB, NPPF, LISTPB, NLPS, IFLINE, ILLIST, & IPBOUN, LINKPB, IWTPBF, LINKP, LINKS, SIDEOK, NOROOM) IF (NOROOM) GO TO 310 SIDEOK = .TRUE. CALL LINKBC (ML, MS, NOLD(13) + 1, N(13), N(2), N(26), N(13), & N(14), N(20), ILBF, IFLB, NLPF, LISTLB, NLPS, IFLINE, ILLIST, & ILBOUN, LINKLB, IWTLBF, LINKL, LINKS, SIDEOK, NOROOM) IF (NOROOM) GO TO 310 CALL LINKBC (ML, MS, NOLD(15) + 1, N(15), N(2), N(27), N(15), & N(16), N(20), ISBF, IFSB, NSPF, LISTSB, NLPS, IFLINE, ILLIST, & ISBOUN, LINKSB, IWTSBF, LINKL, LINKS, SIDEOK, NOROOM) IF (NOROOM) GO TO 310 C IF NO BODY CARDS HAVE BEEN READ, ASSUME THE BODY IS ALL THE REGIONS C AND ALL THE BAR SETS ADDLNK = .FALSE. IF (N(9) .EQ. NOLD(9)) THEN IFOUND = 1 DO 290 I = NOLD(5) + 1, N(5) CALL LTSORT (MS, LINKB, IBARST(I), IPNTR, ADDLNK) IF (IPNTR .EQ. I) THEN III(1) = -IBARST(I) CALL INBODY (MR, N(9), III(1), IFOUND, IRPB, ADDOLD, & NOROOM) IF (NOROOM) GO TO 310 END IF 290 CONTINUE DO 300 I = NOLD(7) + 1, N(7) CALL LTSORT (MR, LINKR, IREGN(I), IPNTR, ADDLNK) IF (IPNTR .EQ. I) THEN CALL INBODY (MR, N(9), IREGN(I), IFOUND, IRPB, ADDOLD, & NOROOM) IF (NOROOM) GO TO 310 END IF 300 CONTINUE END IF C SUCCESSFUL COMPLETION - WRITE SUMMARY OF SUCCESSFUL READS IF (NODATA) THEN CALL MESSAGE(' ') CALL MESSAGE(' *----------------------------------------- - *') CALL MESSAGE(' NO FASTQ DATA HAS BEEN FOUND IN CURRENT FILE') CALL MESSAGE(' *----------------------------------------- - *') RETURN END IF CALL MESSAGE(' ') CALL MESSAGE('FILE SUCCESSFULLY READ') CALL STRLNG (TITLE, LEN) WRITE(*, 10300) TITLE(1:LEN) IF (MERGE) THEN IF (N(1) .GT. 0) WRITE(*, 10310) N(1) - NOLD(1), N(1) IF (N(2) .GT. 0) WRITE(*, 10320) N(2) - NOLD(2), N(2) IF (N(3) .GT. 0) WRITE(*, 10330) N(3) - NOLD(3), N(3) IF (N(5) .GT. 0) WRITE(*, 10340) N(5) - NOLD(5), N(5) IF (N(7) .GT. 0) WRITE(*, 10350) N(7) - NOLD(7), N(7) IF (N(10) .GT. 0) WRITE(*, 10360) N(10) - NOLD(10), N(10) IF (N(11) .GT. 0) WRITE(*, 10370) N(11) - NOLD(11), N(11) IF (N(13) .GT. 0) WRITE(*, 10380) N(13) - NOLD(13), N(13) IF (N(15) .GT. 0) WRITE(*, 10390) N(15) - NOLD(15), N(15) IF (N(28) .GT. 0) WRITE(*, 10400) N(28) - NOLD(28), N(28) IF (N(29) .GT. 0) WRITE(*, 10410) N(29) - NOLD(29), N(29) ELSE IF (N(1) .GT. 0) WRITE(*, 10420) N(1) IF (N(2) .GT. 0) WRITE(*, 10430) N(2) IF (N(3) .GT. 0) WRITE(*, 10440) N(3) IF (N(5) .GT. 0) WRITE(*, 10450) N(5) IF (N(7) .GT. 0) WRITE(*, 10460) N(7) IF (N(10) .GT. 0) WRITE(*, 10480) N(10) IF (N(11) .GT. 0) WRITE(*, 10490) N(11) IF (N(13) .GT. 0) WRITE(*, 10500) N(13) IF (N(15) .GT. 0) WRITE(*, 10510) N(15) IF (N(28) .GT. 0) WRITE(*, 10520) N(28) IF (N(29) .GT. 0) WRITE(*, 10470) N(29) END IF RETURN C MORE ROOM IN DIMENSIONS NEEDED 310 CONTINUE CALL MESSAGE(' ') CALL MESSAGE('DIMENSIONS MUST BE INCREASED - PLEASE WAIT') DO 320 I = 1, 29 N(I) = NOLD(I) 320 CONTINUE IF (LHOLD .EQ. 0) THEN TITLE = ' ' ELSE TITLE(LHOLD + 1:) = ' ' END IF NOROOM = .TRUE. C FIND OUT HOW MUCH ROOM IS NEEDED REWIND IUNIT NEWMP = 0 NEWML = 0 NEWMS = 0 NEWMR = 0 330 CONTINUE CALL FREFLD (IUNIT, IDUMP, ' ', NIN, IOSTAT, IFOUND, KIN, CIN, & IIN, RIN) C CHECK FOR THE END OF THE FILE OR FOR AN ERROR IF (IOSTAT .LT. 0) GO TO 340 C COUNT THE CARDS FOR NEEDED DIMENSIONING IF (CIN(1)(1:5) .EQ. 'POINT') THEN NEWMP = NEWMP + 1 ELSE IF (CIN(1)(1:5) .EQ. 'LINE ') THEN NEWML = NEWML + 1 ELSE IF (CIN(1)(1:5) .EQ. 'SIDE ') THEN NEWMS = NEWMS + 1 ELSE IF (CIN(1)(1:6) .EQ. 'REGION') THEN NEWMR = NEWMR + 1 END IF GO TO 330 C GET THE LARGEST RATIO OF NEEDED/CURRENT 340 CONTINUE RATIO = AMAX1(DBLE(NEWMP)/DBLE(MP), DBLE(NEWML)/DBLE(ML), & DBLE(NEWMS)/DBLE(MS), DBLE(NEWMR)/DBLE(MR), 1.5000001)*1.1 RETURN 10000 FORMAT (' A POINT NO. OF:', I7, ' IS NOT ALLOWED', /, & ' THIS POINT WILL NOT BE INPUT INTO DATABASE') 10010 FORMAT (' A LINE NO. OF:', I7, ' IS NOT ALLOWED', /, & ' THIS LINE WILL NOT BE INPUT INTO DATABASE') 10020 FORMAT (' FOR LINE NO.:', I5, ' NOT ENOUGH INFORMATION IS ', & 'SUPPLIED',/, ' THIS LINE WILL NOT BE INPUT INTO DATABASE') 10030 FORMAT (' LINE TYPE "', A4, '" FOR LINE:', I5, ' IS ILLEGAL.', /, & ' LINE TYPE CHANGED TO "STRAIGHT"') 10040 FORMAT (' A SIDE NO. OF:', I7, ' IS NOT ALLOWED', /, & ' THIS SIDE WILL NOT BE INPUT INTO DATABASE') 10050 FORMAT (' FOR SIDE NO.:', I5, ' NOT ENOUGH INFORMATION IS ', & 'SUPPLIED',/, ' THIS SIDE WILL NOT BE INPUT INTO DATABASE') 10060 FORMAT (' A REGION NO. OF:', I7, ' IS NOT ALLOWED', /, & ' THIS REGION WILL NOT BE INPUT INTO DATABASE') 10070 FORMAT (' REGION NO:', I5, ' IS NOT IN THE DATABASE', /, & ' THUS NO SIZE CAN BE ENTERED') 10080 FORMAT (' FOR REGION NO.:', I5, ' NOT ENOUGH INFORMATION IS ', & 'SUPPLIED'/, ' THIS REGION WILL NOT BE INPUT INTO DATABASE') 10090 FORMAT (' A REGION NO. OF:', I7, ' IS NOT IN THE DATABASE', /, & ' THE HOLES FOR THIS REGION WILL NOT BE INPUT INTO DATABASE') 10100 FORMAT (' FOR HOLE REGION NO.:', I5, ' NOT ENOUGH INFORMATION ', & 'IS SUPPLIED'/,' THE HOLES FOR THIS REGION WILL NOT BE INPUT ', & 'INTO DATABASE') 10110 FORMAT (' A REGION NO. OF:', I7, ' IS NOT ALLOWED', /, & ' THE SCHEME FOR THIS REGION WILL NOT BE INPUT INTO DATABASE') 10120 FORMAT (' THE DEFAULT SCHEME HAS NOT BEEN SPECIFIED ADEQUATELY', & /, ' THIS DEFAULT WILL NOT BE INPUT INTO THE DATABASE') 10130 FORMAT (' FOR THE SCHEME FOR REGION NO.:', I5, & ' NOT ENOUGH INFORMATION IS SUPPLIED', & /, ' THIS SCHEME WILL NOT BE INPUT INTO DATABASE') 10140 FORMAT (' FOR INTERVALS TO BE INPUT ON LINES IN SIDE: ', I5, /, & ' NOT ENOUGH INFORMATION IS SUPPLIED', /, & ' THESE INTERVALS WILL NOT BE ASSIGNED') 10150 FORMAT (' FOR INTERVALS TO BE INPUT ON LINE: ', I5, /, & ' NOT ENOUGH INFORMATION IS SUPPLIED', /, & ' THIS INTERVAL WILL NOT BE ASSIGNED') 10160 FORMAT (' FOR FACTORS TO BE INPUT ON LINES IN SIDE: ', I5, /, & ' NOT ENOUGH INFORMATION IS SUPPLIED', /, & ' THESE INTERVALS WILL NOT BE ASSIGNED') 10170 FORMAT (' FOR FACTORS TO BE INPUT ON LINE: ', I5, /, & ' NOT ENOUGH INFORMATION IS SUPPLIED', /, & ' THIS INTERVAL WILL NOT BE ASSIGNED') 10200 FORMAT (' FOR POINBC NO.:', I5, ' NOT ENOUGH INFORMATION IS ', & 'SUPPLIED',/, ' THIS POINBC WILL NOT BE INPUT INTO DATABASE') 10210 FORMAT (' OLD POINBC NO:', I5, ' TO NEW POINBC NO:', I5) 10220 FORMAT (' FOR NODEBC NO.:', I5, ' NOT ENOUGH INFORMATION IS ', & 'SUPPLIED',/, ' THIS NODEBC WILL NOT BE INPUT INTO DATABASE') 10230 FORMAT (' OLD NODEBC NO:', I5, ' TO NEW NODEBC NO:', I5) 10240 FORMAT (' FOR ELEMBC NO.:', I5, ' NOT ENOUGH INFORMATION IS ', & 'SUPPLIED',/, ' THIS ELEMBC WILL NOT BE INPUT INTO DATABASE') 10250 FORMAT (' OLD ELEMBC NO:', I5, ' TO NEW ELEMBC NO:', I5) 10260 FORMAT (' WEIGHTING OF ', A5, ' FLAG:', I5, ' NOT POSSIBLE', /, & 'FLAG NOT FOUND') 10270 FORMAT (' WEIGHTING OF ', A4, ' FLAG:', I5, ' NOT POSSIBLE', /, & 'FLAG NOT FOUND') 10280 FORMAT (' WEIGHTING TYPE OF ', A5, ' CANNOT BE ENTERED') 10290 FORMAT (' NOT ENOUGH INFORMATION SUPPLIED WITH CARD: ', A) 10300 FORMAT (' TITLE: ', A) 10310 FORMAT (' ', I5, ' NEW POINTS READ - TOTAL POINTS:', I5) 10320 FORMAT (' ', I5, ' NEW LINES READ - TOTAL LINES:', I5) 10330 FORMAT (' ', I5, ' NEW SIDES READ - TOTAL SIDES:', I5) 10340 FORMAT (' ', I5, ' NEW BAR SETS READ - TOTAL BAR SETS:', I5) 10350 FORMAT (' ', I5, ' NEW REGIONS READ - TOTAL REGIONS:', I5) 10360 FORMAT (' ', I5, ' NEW SCHEMES READ - TOTAL SCHEMES:', I5) 10370 FORMAT (' ', I5, ' NEW POINBCS READ - TOTAL POINBCS:', I5) 10380 FORMAT (' ', I5, ' NEW NODEBCS READ - TOTAL NODEBCS:', I5) 10390 FORMAT (' ', I5, ' NEW ELEMBCS READ - TOTAL ELEMBCS:', I5) 10400 FORMAT (' ', I5, ' NEW RENUMS READ - TOTAL RENUMS:', I5) 10410 FORMAT (' ', I5, ' NEW HOLES READ - TOTAL HOLES:', I5) 10420 FORMAT (' NUMBER OF POINTS READ:', I5) 10430 FORMAT (' NUMBER OF LINES READ:', I5) 10440 FORMAT (' NUMBER OF SIDES READ:', I5) 10450 FORMAT (' NUMBER OF BAR SETS READ:', I5) 10460 FORMAT (' NUMBER OF REGIONS READ:', I5) 10470 FORMAT (' NUMBER OF HOLES READ:', I5) 10480 FORMAT (' NUMBER OF SCHEMES READ:', I5) 10490 FORMAT (' NUMBER OF POINBCS READ:', I5) 10500 FORMAT (' NUMBER OF NODEBCS READ:', I5) 10510 FORMAT (' NUMBER OF ELEMBCS READ:', I5) 10520 FORMAT (' NUMBER OF RENUMS READ:', I5) END