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