lib
/
EXODUS
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
Cloned SEACAS for EXODUS library with extra build files for internal package management.
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
6 Commits
1 Branch
0 Tags
19 MiB
 
 
 
 
 
 
Tag: Branch: Tree: 6ce61ef92b
Branches Tags
${ item.name }
Create tag ${ searchTerm }
Create branch ${ searchTerm }
from '6ce61ef92b'
${ noResults }
EXODUS/packages/seacas/applications/fastq/wrfsq.f

790 lines
26 KiB
Raw Blame History

C Copyright(C) 1999-2020 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 WRFSQ (IUNIT, MP, ML, MS, MR, MSNAP, MSC, MCOM, ICOM,
& JCOM, CIN, RIN, IIN, KIN, 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, LINKP, LINKL, LINKS, LINKB, LINKR, LINKSC, LINKPB,
& LINKLB, LINKSB, IWTPBF, IWTLBF, IWTSBF, RSIZE, IFHOLE, NHPR,
& IHLIST, IRGFLG, ISCHM, SCHEME, NUMBER, DEFSCH, DEFSIZ, TITLE,
& OPTIM, THREE, EIGHT, NINE, SNAP, SNAPDX, NSNAP, REGWRT, BARWRT)
C***********************************************************************
C SUBROUTINE WRFSQ = WRITES FASTQ CARD FILE
C***********************************************************************
C SUBROUTINE CALLED BY:
C FASTQ = A PROGRAM TO QUICKLY PREPARE FASTQ INPUT
C***********************************************************************
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(MS*3)
DIMENSION IREGN(MR), IMAT(MR), NSPR(MR), IFSIDE(MR), ISLIST(MR*4)
DIMENSION IRPB(MR), RSIZE(MR), IFHOLE(MR), NHPR(MR), IHLIST(MR*2)
DIMENSION ISCHM(MSC), SCHEME(MSC), IRGFLG(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, MP), IWTSBF(3, MP)
DIMENSION LINKP(2, MP), LINKL(2, ML), LINKS(2, MS), LINKB(2, MS)
DIMENSION LINKR(2, MR), LINKSC(2, MR)
DIMENSION LINKPB(2, MP), LINKLB(2, ML), LINKSB(2, ML)
DIMENSION NUMBER(MSC), SNAPDX(2, MSNAP), NSNAP(2)
DIMENSION KIN(MCOM), IIN(MCOM), RIN(MCOM)
DIMENSION N(29), ID (13)
CHARACTER*72 SCHEME, DEFSCH, TITLE, DUMMY, CIN(MCOM)
CHARACTER NUMBER*80, TYPE(7)*5
LOGICAL IANS, OPTIM, THREE, EIGHT, NINE, ADDLNK, SNAP
LOGICAL REGWRT, BARWRT, FLAG, GOWRIT, STAR
DATA TYPE/' STR', ' CORN', ' CIRC', ' CIRM', ' PARA', ' CIRR',
& ' ELIP'/
ADDLNK = .FALSE.
GOWRIT = .FALSE.
XADD = 0.
YADD = 0.
C WRITE OUT ONLY THE REGIONS OF INTEREST IF THE REGWRT FLAG HAS BEEN SET
IF (REGWRT) THEN
C SEE IF A SHIFT OF THE REGION IS NEEDED
CALL INTRUP ('SHIFT REGION', IANS, MCOM, ICOM, JCOM, CIN, IIN,
& RIN, KIN)
IF (IANS) THEN
IZ = 0
CALL FREFLD (IZ, IZ, 'X SHIFT: ', MCOM, IOSTAT, IFOUND, KIN,
& CIN, IIN, RIN)
IF (IFOUND .GT. 0) THEN
XADD = RIN (1)
ELSE
XADD = 0.
ENDIF
CALL FREFLD (IZ, IZ, 'Y SHIFT: ', MCOM, IOSTAT, IFOUND, KIN,
& CIN, IIN, RIN)
IF (IFOUND .GT. 0) THEN
YADD = RIN (1)
ELSE
YADD = 0.
ENDIF
ENDIF
FLAG = .FALSE.
CALL FLAGD (MP, N (18), LINKP, IPOINT, FLAG)
CALL FLAGD (ML, N (19), LINKL, ILINE, FLAG)
CALL FLAGD (MS, N (20), LINKS, ISIDE, FLAG)
CALL FLAGD (MS, N (21), LINKB, IBARST, FLAG)
CALL FLAGD (MR, N (22), LINKR, IREGN, FLAG)
CALL MESSAGE('WRITE REGIONS FROM <I1> TO <I2>')
CALL MESSAGE('HIT RETURN TO END INPUT')
100 CONTINUE
IF (ICOM.GT.JCOM)THEN
CALL FREFLD (IZ, IZ, '>', MCOM, IOSTAT, JCOM, KIN, CIN,
& IIN, RIN)
ICOM = 1
ENDIF
CALL GETI12 (MCOM, ICOM, JCOM, CIN, IIN, KIN, I1, I2, IFOUND)
IF (IFOUND .GT. 0) THEN
IF (I1 .GT. 0) THEN
CALL CHECK (I1, I2, N (22))
C FLAG ALL DATA ASSOCIATED WITH THE REGIONS
DO 150 I = I1, I2
CALL LTSORT (MR, LINKR, I, II, ADDLNK)
IF (II.GT.0) THEN
GOWRIT = .TRUE.
IREGN (II) = -IABS (IREGN (II))
DO 140 J = IFSIDE (II), IFSIDE (II)+NSPR (II)-1
C FLAG SIDE DATA
CALL LTSORT (MS, LINKS, ISLIST (J), JJ, ADDLNK)
IF ((ISLIST (J) .GT. 0) .AND. (JJ .GT. 0)) THEN
ISIDE (JJ) = -IABS (ISIDE (JJ))
DO 120 K = IFLINE (JJ), IFLINE (JJ) +
& NLPS (JJ)-1
CALL LTSORT (ML, LINKL, ILLIST (K), KK,
& ADDLNK)
IF (KK .GT. 0 )THEN
ILINE (KK) = -IABS (ILINE (KK))
DO 110 L = 1, 3
IF (LCON (L, KK) .GT. 0) THEN
CALL LTSORT (MP, LINKP,
& LCON (L, KK), LL, ADDLNK)
IF (LL. GT. 0) THEN
IPOINT (LL) =
& -IABS (IPOINT (LL))
ENDIF
ENDIF
110 CONTINUE
ENDIF
120 CONTINUE
C FLAG LINE DATA
ELSE
JJ = IABS (ISLIST (J))
CALL LTSORT (ML, LINKL, JJ, KK, ADDLNK)
IF (KK.GT.0)THEN
ILINE (KK) = -IABS (ILINE (KK))
DO 130 L = 1, 3
IF (LCON (L, KK) .GT. 0) THEN
CALL LTSORT (MP, LINKP,
& LCON (L, KK), LL, ADDLNK)
IF (LL .GT. 0) THEN
IPOINT (LL) =
& - IABS (IPOINT (LL))
ENDIF
ENDIF
130 CONTINUE
ENDIF
ENDIF
140 CONTINUE
ENDIF
150 CONTINUE
GOTO 100
ENDIF
ENDIF
C WRITE OUT THE BARSET DATA
ELSEIF (BARWRT) THEN
FLAG = .FALSE.
CALL FLAGD (MP, N (18), LINKP, IPOINT, FLAG)
CALL FLAGD (ML, N (19), LINKL, ILINE, FLAG)
CALL FLAGD (MS, N (20), LINKS, ISIDE, FLAG)
CALL FLAGD (MS, N (21), LINKB, IBARST, FLAG)
CALL FLAGD (MR, N (22), LINKR, IREGN, FLAG)
GOWRIT = .FALSE.
CALL MESSAGE('WRITE BARSETS FROM <I1> TO <I2>')
CALL MESSAGE('HIT RETURN TO END INPUT')
160 CONTINUE
IF (ICOM .GT. JCOM) THEN
CALL FREFLD (IZ, IZ, '>', MCOM, IOSTAT, JCOM, KIN, CIN,
& IIN, RIN)
ICOM = 1
ENDIF
CALL GETI12 (MCOM, ICOM, JCOM, CIN, IIN, KIN, I1, I2, IFOUND)
IF (IFOUND .GT. 0) THEN
IF (I1 .GT. 0) THEN
CALL CHECK (I1, I2, N (21))
C FLAG ALL LINES ASSOCIATED WITH THE BARSETS
DO 190 I = I1, I2
CALL LTSORT (MS, LINKB, I, II, ADDLNK)
IF (II .GT. 0) THEN
GOWRIT = .TRUE.
IBARST (II) = -IABS (IBARST (II))
DO 180 J = JFLINE (II), JFLINE (II) + NLPB (II) - 1
JJ = IABS (JLLIST (J))
CALL LTSORT (ML, LINKL, JJ, KK, ADDLNK)
IF (KK .GT. 0) THEN
ILINE (KK) = -IABS (ILINE (KK))
DO 170 L = 1, 3
IF (LCON (L, KK) .GT. 0) THEN
CALL LTSORT (MP, LINKP, LCON (L, KK),
& LL, ADDLNK)
IF (LL .GT. 0) THEN
IPOINT (LL) = -IABS (IPOINT (LL))
ENDIF
ENDIF
170 CONTINUE
ENDIF
180 CONTINUE
ENDIF
190 CONTINUE
GOTO 160
ENDIF
ENDIF
C OTHERWISE FLAG ALL THE DATA TO BE WRITTEN
ELSE
FLAG = .TRUE.
CALL FLAGD (MP, N (18), LINKP, IPOINT, FLAG)
CALL FLAGD (ML, N (19), LINKL, ILINE, FLAG)
CALL FLAGD (MS, N (20), LINKS, ISIDE, FLAG)
CALL FLAGD (MS, N (21), LINKB, IBARST, FLAG)
CALL FLAGD (MR, N (22), LINKR, IREGN, FLAG)
GOWRIT = .TRUE.
ENDIF
IF (.NOT. GOWRIT) THEN
CALL MESSAGE('** NO DATA HAS BEEN WRITTEN **')
GOTO 510
ENDIF
C WRITE OUT THE TITLE
CALL STRLNG (TITLE, LEN)
WRITE (IUNIT, 10010) TITLE(1:LEN)
C WRITE OUT THE POINTS IN ORDER
DO 200 I = 1, N(18)
CALL LTSORT (MP, LINKP, I, J, ADDLNK)
IF ((J .GT. 0) .AND. (IPOINT (J) .LT. 0)) THEN
WRITE (IUNIT, 10020) IABS (IPOINT(J)),
& COOR(1, J) + XADD, COOR(2, J) + YADD
END IF
200 CONTINUE
C WRITE OUT THE LINES IN ORDER
DO 210 I = 1, N(19)
CALL LTSORT (ML, LINKL, I, J, ADDLNK)
IF ((J .GT. 0) .AND. (ILINE (J) .LT. 0)) THEN
WRITE (IUNIT, 10030) IABS (ILINE(J)), TYPE(LTYPE(J)),
& LCON(1, J), LCON(2, J), LCON(3, J), NINT(J), FACTOR(J)
END IF
210 CONTINUE
C WRITE OUT THE SIDES IN ORDER
DO 230 I = 1, N(20)
CALL LTSORT (MS, LINKS, I, J, ADDLNK)
IF ((J .GT. 0) .AND. (ISIDE (J) .LT. 0)) THEN
N2 = IFLINE(J) - 1
220 CONTINUE
N1 = N2 + 1
IF (N1 .EQ. IFLINE(J)) THEN
N2 = N1 + 9
ELSE
N2 = N1 + 10
END IF
N2 = MIN0(N2, IFLINE(J) + NLPS(J) - 1)
IF (N2 .LT. IFLINE(J) + NLPS(J) - 1) THEN
IF (N1 .EQ. IFLINE(J)) THEN
WRITE (IUNIT, 10040) ' SIDE ', IABS (ISIDE(J)),
& (ILLIST(K), K = N1, N2)
ELSE
WRITE (IUNIT, 10050) (ILLIST(K), K = N1, N2)
END IF
GO TO 220
ELSE
IF (N1 .EQ. IFLINE(J)) THEN
WRITE (IUNIT, 10060) 'SIDE ', IABS (ISIDE(J)),
& (ILLIST(K), K = N1, N2)
ELSE
WRITE (IUNIT, 10070) (ILLIST(K), K = N1, N2)
END IF
END IF
END IF
230 CONTINUE
C WRITE OUT THE BAR SETS IN ORDER
DO 250 I = 1, N(21)
CALL LTSORT (MS, LINKB, I, J, ADDLNK)
IF ((J .GT. 0) .AND. (IBARST (J) .LT. 0)) THEN
N2 = JFLINE(J) - 1
240 CONTINUE
N1 = N2 + 1
IF (N1 .EQ. JFLINE(J)) THEN
N2 = N1 + 7
ELSE
N2 = N1 + 10
END IF
N2 = MIN0(N2, JFLINE(J) + NLPB(J) - 1)
IF (N2 .LT. JFLINE(J) + NLPB(J) - 1) THEN
IF (N1 .EQ. JFLINE(J)) THEN
WRITE (IUNIT, 10040) ' BARSET', IABS (IBARST(J)),
& JMAT(J), JCENT(J), (JLLIST(K), K = N1, N2)
ELSE
WRITE (IUNIT, 10050) (JLLIST(K), K = N1, N2)
END IF
GO TO 240
ELSE
IF (N1 .EQ. JFLINE(J)) THEN
WRITE (IUNIT, 10060) 'BARSET', IABS (IBARST(J)),
& JMAT(J), JCENT(J), (JLLIST(K), K = N1, N2)
ELSE
WRITE (IUNIT, 10070) (JLLIST(K), K = N1, N2)
END IF
END IF
END IF
250 CONTINUE
C WRITE OUT THE REGIONS IN ORDER
DO 270 I = 1, N(22)
CALL LTSORT (MR, LINKR, I, J, ADDLNK)
IF ((J .GT. 0) .AND. (IRGFLG(J) .LE. -1) .AND.
& (IREGN (J) .LE. 0)) THEN
N2 = IFSIDE(J) - 1
260 CONTINUE
N1 = N2 + 1
IF (N1 .EQ. IFSIDE(J)) THEN
N2 = N1 + 8
ELSE
N2 = N1 + 10
END IF
N2 = MIN0(N2, IFSIDE(J) + NSPR(J) - 1)
IF (N2 .LT. IFSIDE(J) + NSPR(J) - 1) THEN
IF (N1 .EQ. IFSIDE(J)) THEN
WRITE (IUNIT, 10040) ' REGION', IABS (IREGN(J)),
& IMAT(J), (ISLIST(K), K = N1, N2)
ELSE
WRITE (IUNIT, 10050) (ISLIST(K), K = N1, N2)
END IF
GO TO 260
ELSE
IF (N1 .EQ. IFSIDE(J)) THEN
WRITE (IUNIT, 10060) 'REGION', IABS (IREGN(J)),
& IMAT(J), (ISLIST(K), K = N1, N2)
ELSE
WRITE (IUNIT, 10070) (ISLIST(K), K = N1, N2)
END IF
END IF
C WRITE OUT THE REGION INTERVAL SIZE DATA
IF (RSIZE(J) .GT. 0.)
& WRITE (IUNIT, 10080) 'SIZE ', RSIZE(J),
& IABS (IREGN(J))
END IF
270 CONTINUE
IF (DEFSIZ .GT. 0.) WRITE (IUNIT, 10080) 'SIZE ', DEFSIZ
C WRITE OUT THE HOLES IN ORDER
DO 290 I = 1, N(22)
CALL LTSORT (MR, LINKR, I, J, ADDLNK)
IF ((NHPR(J) .GT. 0) .AND. (IREGN (J) .LT. 0)) THEN
N2 = IFHOLE(J) - 1
280 CONTINUE
N1 = N2 + 1
IF (N1 .EQ. IFHOLE(J)) THEN
N2 = N1 + 9
ELSE
N2 = N1 + 10
END IF
N2 = MIN0(N2, IFHOLE(J) + NHPR(J) - 1)
IF (N2 .LT. IFHOLE(J) + NHPR(J) - 1) THEN
IF (N1 .EQ. IFHOLE(J)) THEN
WRITE (IUNIT, 10040) ' HOLE ', IABS (IREGN(J)),
& (IHLIST(K), K = N1, N2)
ELSE
WRITE (IUNIT, 10050) (IHLIST(K), K = N1, N2)
END IF
GO TO 280
ELSE
IF (N1 .EQ. IFHOLE(J)) THEN
WRITE (IUNIT, 10060) ' HOLE ', IABS (IREGN(J)),
& (IHLIST(K), K = N1, N2)
ELSE
WRITE (IUNIT, 10070) (IHLIST(K), K = N1, N2)
END IF
END IF
END IF
290 CONTINUE
C WRITE OUT THE GROUPS IN ORDER
DO 310 I = 1, N(22)
CALL LTSORT (MR, LINKR, I, J, ADDLNK)
IF ((J .GT. 0) .AND. (IRGFLG(J) .GE. 1)) THEN
N2 = IFSIDE(J) - 1
300 CONTINUE
N1 = N2 + 1
IF (N1 .EQ. IFSIDE(J)) THEN
N2 = N1 + 9
ELSE
N2 = N1 + 10
END IF
N2 = MIN0(N2, IFSIDE(J) + NSPR(J) - 1)
IF (N2 .LT. IFSIDE(J) + NSPR(J) - 1) THEN
IF (N1 .EQ. IFSIDE(J)) THEN
WRITE (IUNIT, 10040) ' GROUP ', IABS (IREGN(J)),
& (ISLIST(K), K = N1, N2)
ELSE
WRITE (IUNIT, 10050) (ISLIST(K), K = N1, N2)
END IF
GO TO 300
ELSE
IF (N1 .EQ. IFSIDE(J)) THEN
WRITE (IUNIT, 10060) 'GROUP ', IABS (IREGN(J)),
& (ISLIST(K), K = N1, N2)
ELSE
WRITE (IUNIT, 10070) (ISLIST(K), K = N1, N2)
END IF
END IF
END IF
310 CONTINUE
C WRITE OUT THE SCHEMES IN ORDER
DO 320 I = 1, N(24)
CALL LTSORT (MR, LINKSC, I, J, ADDLNK)
IF (J .GT. 0) THEN
CALL LTSORT (MR, LINKR, ISCHM (J), JJ, ADDLNK)
IF ((JJ .GT. 0) .AND. (IREGN (JJ) .LT. 0)) THEN
CALL STRLNG (SCHEME(J), LEN)
DUMMY = SCHEME(J)(1:LEN)
WRITE (IUNIT, 10110) ISCHM(J), DUMMY(1:LEN)
END IF
END IF
320 CONTINUE
CALL STRLNG (DEFSCH, LEN)
IZERO = 0
WRITE (IUNIT, 10110) IZERO, DEFSCH(1:LEN)
C WRITE OUT THE BODY LIST
N2 = 0
KMAX = 11
330 CONTINUE
N1 = N2 + 1
IF (N(9) .GT. 0) THEN
KOUNT = 0
DO 340 I = N1, N(9)
IF (IRPB(I) .GT. 0) THEN
CALL LTSORT (MR, LINKR, IRPB(I), J, ADDLNK)
ELSE IF (IRPB(I) .LT. 0) THEN
CALL LTSORT (MS, LINKB, IABS(IRPB(I)), J, ADDLNK)
ELSE
J = 0
ENDIF
IF ( ((IRPB(I) .GT. 0) .AND. (J .GT. 0) .AND.
& (IREGN (J) .LT. 0)) .OR.
& ((IRPB(I) .LT. 0) .AND. (J .GT. 0) .AND.
& (IBARST (J) .LT. 0)) ) THEN
KOUNT = KOUNT + 1
ID (KOUNT) = IRPB (I)
ENDIF
N2 = I
IF (KOUNT .EQ. KMAX) GOTO 350
340 CONTINUE
350 CONTINUE
IF (N2 .LT. N(9)) THEN
IF (N1 .EQ. 1) THEN
WRITE (IUNIT, 10040) ' BODY ', (ID (I), I = 1, KOUNT)
ELSE
WRITE (IUNIT, 10050) (ID(I), I = 1, KOUNT)
END IF
GO TO 330
ELSEIF (KOUNT .GT. 0) THEN
IF (N1 .EQ. 1) THEN
WRITE (IUNIT, 10060) 'BODY ', (ID (I), I = 1, KOUNT)
ELSE
WRITE (IUNIT, 10070) (ID (I), I = 1, KOUNT)
END IF
ELSE
WRITE (IUNIT, 10000)
END IF
END IF
C WRITE OUT THE POINT BOUNDARY FLAGS IN ORDER
DO 390 I = 1, N(25)
CALL LTSORT (MP, LINKPB, I, J, ADDLNK)
IF (J .GT. 0) THEN
STAR = .FALSE.
N2 = IFPB(J) - 1
360 CONTINUE
N1 = N2 + 1
IF (N1 .EQ. IFPB(J)) THEN
KMAX = 10
ELSE
KMAX = 11
END IF
KOUNT = 0
DO 370 K = N1, IFPB(J) + NPPF(J) - 1
CALL LTSORT (MP, LINKP, LISTPB (1, K), JJ, ADDLNK)
IF ((JJ .GT. 0) .AND. (IPOINT (JJ) .LT. 0)) THEN
KOUNT = KOUNT + 1
ID (KOUNT) = LISTPB (1, K)
ENDIF
N2 = K
IF (KOUNT .EQ. KMAX) GOTO 380
370 CONTINUE
380 CONTINUE
IF (N2 .LT. IFPB(J) + NPPF(J) - 1) THEN
STAR = .TRUE.
IF (N1 .EQ. IFPB(J)) THEN
WRITE (IUNIT, 10040) ' POINBC', IPBF(J),
& (ID (K), K = 1, KOUNT)
ELSE
WRITE (IUNIT, 10050) (ID (K), K = 1, KOUNT)
END IF
GO TO 360
ELSEIF (KOUNT .GT. 0) THEN
IF (N1 .EQ. IFPB(J)) THEN
WRITE (IUNIT, 10060) ' POINBC', IPBF(J),
& (ID (K), K = 1, KOUNT)
ELSE
WRITE (IUNIT, 10070) (ID (K), K = 1, KOUNT)
END IF
ELSEIF (STAR) THEN
WRITE (IUNIT, 10000)
END IF
IF (IWTPBF(1, J) .GT. 0) THEN
WRITE (IUNIT, 10100) 'POINT', IPBF(J), IWTPBF(1, J),
& IWTPBF(2, J)
END IF
END IF
390 CONTINUE
C WRITE OUT THE LINE BOUNDARY FLAGS IN ORDER
DO 430 I = 1, N(26)
CALL LTSORT (ML, LINKLB, I, J, ADDLNK)
IF (J .GT. 0) THEN
STAR = .FALSE.
N2 = IFLB(J) - 1
400 CONTINUE
N1 = N2 + 1
IF (N1 .EQ. IFLB(J)) THEN
KMAX = 10
ELSE
KMAX = 11
END IF
KOUNT = 0
DO 410 K = N1, IFLB(J) + NLPF(J) - 1
CALL LTSORT (ML, LINKL, LISTLB (1, K), JJ, ADDLNK)
IF ((JJ .GT. 0) .AND. (ILINE (JJ) .LT. 0)) THEN
KOUNT = KOUNT + 1
ID (KOUNT) = LISTLB (1, K)
ENDIF
N2 = K
IF (KOUNT .EQ. KMAX) GOTO 420
410 CONTINUE
420 CONTINUE
IF (N2 .LT. IFLB(J) + NLPF(J) - 1) THEN
STAR = .TRUE.
IF (N1 .EQ. IFLB(J)) THEN
WRITE (IUNIT, 10040) ' NODEBC', ILBF(J),
& (ID (K), K = 1, KOUNT)
ELSE
WRITE (IUNIT, 10050) (ID (K), K = 1, KOUNT)
END IF
GO TO 400
ELSEIF (KOUNT .GT. 0) THEN
IF (N1 .EQ. IFLB(J)) THEN
WRITE (IUNIT, 10060) ' NODEBC', ILBF(J),
& (ID (K), K = 1, KOUNT)
ELSE
WRITE (IUNIT, 10070) (ID (K), K = 1, KOUNT)
END IF
ELSEIF (STAR) THEN
WRITE (IUNIT, 10000)
END IF
IF (IWTLBF(1, J) .NE. 0) THEN
IF (IWTLBF(3, J) .GT. 0) THEN
WRITE (IUNIT, 10090) ' LINE', ILBF(J), IWTLBF(1, J),
& IWTLBF(2, J), IWTLBF(3, J)
ELSE
WRITE (IUNIT, 10100) ' LINE', ILBF(J), IWTLBF(1, J),
& IWTLBF(2, J)
END IF
END IF
END IF
430 CONTINUE
C WRITE OUT THE SIDE BOUNDARY FLAGS IN ORDER
DO 470 I = 1, N(27)
CALL LTSORT (ML, LINKSB, I, J, ADDLNK)
IF (J .GT. 0) THEN
STAR = .FALSE.
N2 = IFSB(J) - 1
440 CONTINUE
N1 = N2 + 1
IF (N1 .EQ. IFSB(J)) THEN
KMAX = 10
ELSE
KMAX = 11
END IF
KOUNT = 0
DO 450 K = N1, IFSB(J) + NSPF(J) - 1
CALL LTSORT (ML, LINKL, LISTSB (1, K), JJ, ADDLNK)
IF ((JJ .GT. 0) .AND. (ILINE (JJ) .LT. 0)) THEN
KOUNT = KOUNT + 1
ID (KOUNT) = LISTSB (1, K)
ENDIF
N2 = K
IF (KOUNT .EQ. KMAX) GOTO 460
450 CONTINUE
460 CONTINUE
IF (N2 .LT. IFSB(J) + NSPF(J) - 1) THEN
STAR = .TRUE.
IF (N1 .EQ. IFSB(J)) THEN
WRITE (IUNIT, 10040) ' ELEMBC', ISBF(J),
& (ID (K), K = 1, KOUNT)
ELSE
WRITE (IUNIT, 10050) (ID (K), K = 1, KOUNT)
END IF
GO TO 440
ELSEIF (KOUNT .GT. 0) THEN
IF (N1 .EQ. IFSB(J)) THEN
WRITE (IUNIT, 10060) ' ELEMBC', ISBF(J),
& (ID (K), K = 1, KOUNT)
ELSE
WRITE (IUNIT, 10070) (ID (K), K = 1, KOUNT)
END IF
ELSEIF (STAR) THEN
WRITE (IUNIT, 10000)
END IF
IF (IWTSBF(1, J) .NE. 0) THEN
IF (IWTSBF(3, J) .GT. 0) THEN
WRITE (IUNIT, 10090) ' SIDE', ISBF(J), IWTSBF(1, J),
& IWTSBF(2, J), IWTSBF(3, J)
ELSE
WRITE (IUNIT, 10100) ' SIDE', ISBF(J), IWTSBF(1, J),
& IWTSBF(2, J)
END IF
END IF
END IF
470 CONTINUE
C WRITE OUT THE RENUMBERING CARDS
IF (OPTIM) THEN
IF (N(28) .GT. 0) THEN
DO 480 I = 1, N(28)
DUMMY = NUMBER(I)(6:77)
CALL STRLNG (DUMMY, LEN)
WRITE (IUNIT, 10120) NUMBER(I)(1:5), NUMBER(I)(6:6 + LEN)
480 CONTINUE
ELSE
WRITE (IUNIT, 10130)
END IF
END IF
C WRITE OUT THREE NODE, EIGHT NODE, OR NINE NODE FLAG
IF (THREE) THEN
WRITE (IUNIT, 10140)
ENDIF
IF (EIGHT) THEN
WRITE (IUNIT, 10150)
ELSE IF (NINE) THEN
WRITE (IUNIT, 10160)
END IF
C WRITE DIGITIZER SNAP-TO-GRID FLAG
IF ((NSNAP(1) .GT. 0) .OR. (NSNAP(2) .GT. 0)) THEN
IF (SNAP) THEN
WRITE (IUNIT, 10180)
ELSE
WRITE (IUNIT, 10190)
END IF
C WRITE X-GRID LINES
IF (NSNAP(1) .GT. 0) THEN
N2 = 0
490 CONTINUE
N1 = N2 + 1
N2 = N1 + 4
N2 = MIN0(N2, NSNAP(1))
IF (N2 .LT. NSNAP(1)) THEN
IF (N1 .EQ. 1) THEN
WRITE (IUNIT, 10200) 'XGRID ',
& (SNAPDX(1, K), K = N1, N2)
ELSE
WRITE (IUNIT, 10210) (SNAPDX(1, K), K = N1, N2)
END IF
GO TO 490
ELSE
IF (N1 .EQ. 1) THEN
WRITE (IUNIT, 10220) ' XGRID ',
& (SNAPDX(1, K), K = N1, N2)
ELSE
WRITE (IUNIT, 10230) (SNAPDX(1, K), K = N1, N2)
END IF
END IF
C WRITE Y-GRID LINES
IF (NSNAP(2) .GT. 0) THEN
N2 = 0
500 CONTINUE
N1 = N2 + 1
N2 = N1 + 4
N2 = MIN0(N2, NSNAP(2))
IF (N2 .LT. NSNAP(2)) THEN
IF (N1 .EQ. 1) THEN
WRITE (IUNIT, 10200) ' YGRID ',
& (SNAPDX(2, K), K = N1, N2)
ELSE
WRITE (IUNIT, 10210) (SNAPDX(2, K), K = N1, N2)
END IF
GO TO 500
ELSE
IF (N1 .EQ. 1) THEN
WRITE (IUNIT, 10220) 'YGRID ',
& (SNAPDX(2, K), K = N1, N2)
ELSE
WRITE (IUNIT, 10230) (SNAPDX(2, K), K = N1, N2)
END IF
END IF
END IF
END IF
END IF
C WRITE EXIT
WRITE (IUNIT, 10170)
CALL MESSAGE('FASTQ DATA FILE SUCCESSFULLY WRITTEN')
510 CONTINUE
FLAG=.FALSE.
CALL FLAGD (MP, N(18), LINKP, IPOINT, FLAG)
CALL FLAGD (ML, N(19), LINKL, ILINE, FLAG)
CALL FLAGD (MS, N(20), LINKS, ISIDE, FLAG)
CALL FLAGD (MS, N(21), LINKB, IBARST, FLAG)
CALL FLAGD (MR, N(22), LINKR, IREGN, FLAG)
RETURN
10000 FORMAT (' ')
10010 FORMAT (' TITLE ', /, ' ', A)
10020 FORMAT (' POINT ', I5, 2(5X, 1PE14.7))
10030 FORMAT (' LINE ', I5, 1X, A5, 4(1X, I5), 2X, F6.4)
10040 FORMAT (A7, 11(1X, I5), ' *')
10050 FORMAT (7X, 11(1X, I5), ' *')
10060 FORMAT (A7, 11(1X, I5))
10070 FORMAT (7X, 11(1X, I5))
10080 FORMAT (A7, 1X, 1PE14.7, 2X, I5)
10090 FORMAT (' WEIGHT', 1X, A5, 4(1X, I5))
10100 FORMAT (' WEIGHT', 1X, A5, 3(1X, I5))
10110 FORMAT (' SCHEME', I5, 1X, A)
10120 FORMAT (' RENUM ', A5, 1X, A)
10130 FORMAT (' RENUM ')
10140 FORMAT (' THREE ')
10150 FORMAT (' EIGHT ')
10160 FORMAT (' NINE ')
10170 FORMAT (' EXIT ')
10180 FORMAT (' SNAP ON')
10190 FORMAT (' SNAP OFF')
10200 FORMAT (A7, 5(1X, 1PE13.6), ' *')
10210 FORMAT (7X, 5(1X, 1PE13.6), ' *')
10220 FORMAT (A7, 5(1X, 1PE13.6))
10230 FORMAT (7X, 5(1X, 1PE13.6))
END