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.

145 lines
5.2 KiB

2 years ago
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 STRAIT (MP, ML, MCOM, ICOM, JCOM, CIN, RIN, IIN, KIN,
& IDUMP, N, COOR, LCON, LINKP, LINKL)
C***********************************************************************
C SUBROUTINE STRAIT = STRAIGHTENS LINES IN THE X OR Y DIRECTION
C***********************************************************************
C SUBROUTINE CALLED BY:
C FASTQ = A PROGRAM TO QUICKLY PREPARE QMESH INPUT
C***********************************************************************
C SUBROUTINES CALLED:
C CHECK = CHECKS 2 VALUES FOR BEING OUT OF PRESCRIBED BOUNDS
C***********************************************************************
C VARIABLES USED:
C IANS = LOGICAL RESPONSE FROM YES-NO QUESTION
C ANS = CHARACTER RESPONSE FOR MENU CHOICE
C***********************************************************************
DIMENSION COOR (2, MP), LCON (3, ML), LINKP (2, MP)
DIMENSION LINKL (2, ML), N (29)
DIMENSION KIN (MCOM), IIN (MCOM), RIN (MCOM)
CHARACTER*72 CIN (MCOM)
LOGICAL ADDLNK
IZ=0
ADDLNK=.FALSE.
100 CONTINUE
IF (N (2).GT.0)THEN
CALL MESSAGE(' ')
CALL MESSAGE('STRAIGHTEN LINES <I1> THROUGH <I2> PARALLEL TO'//
& ' THE <X OR Y> AXIS')
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
CALL CHECK (I1, I2, N (19))
ELSE
RETURN
ENDIF
C STRAIGHTEN THE LINE IN THE Y DIRECTION
IF ( (CIN (ICOM) (1:1) .EQ. 'Y') .OR.
& (CIN (ICOM) (1:1) .EQ. 'y'))THEN
ICOM=ICOM+1
DO 120 I=I1, I2
CALL LTSORT (ML, LINKL, I, J, ADDLNK)
IF (J.GT.0)THEN
CALL LTSORT (MP, LINKP, LCON (1, J), IP1, ADDLNK)
CALL LTSORT (MP, LINKP, LCON (2, J), IP2, ADDLNK)
IF ( (IP1.GT.0) .AND. (IP2.GT.0) .AND. (IP1.LE.N (18))
& .AND. (IP2.LE.N (18)) ) THEN
WRITE (*, 10000)I, LCON (1, J), COOR (1, IP1),
& COOR (2, IP1), LCON (2, J), COOR (1, IP2),
& COOR (2, IP2)
110 CONTINUE
IF (ICOM.GT.JCOM)THEN
CALL FREFLD (IZ, IZ, 'NEW CONSTANT X VALUE: ',
& MCOM, IOSTAT, JCOM, KIN, CIN, IIN, RIN)
ICOM=1
ENDIF
IF (KIN (ICOM).GT.0)THEN
COOR (1, IP1)=RIN (ICOM)
COOR (1, IP2)=RIN (ICOM)
ICOM=ICOM+1
ELSE
CALL MESSAGE('BAD INPUT - TRY AGAIN')
ICOM=ICOM+1
GOTO 110
ENDIF
ENDIF
ENDIF
120 CONTINUE
C STRAIGHTEN THE LINE IN THE X DIRECTION
ELSEIF ( (CIN (ICOM) (1:1).EQ.'X') .OR.
& (CIN (ICOM) (1:1).EQ.'x')) THEN
ICOM=ICOM+1
DO 140 I=I1, I2
CALL LTSORT (ML, LINKL, I, J, ADDLNK)
IF (J.GT.0)THEN
CALL LTSORT (MP, LINKP, LCON (1, J), IP1, ADDLNK)
CALL LTSORT (MP, LINKP, LCON (2, J), IP2, ADDLNK)
IF ( (IP1.GT.0) .AND. (IP2.GT.0) .AND. (IP1.LE.N (18))
& .AND. (IP2.LE.N (18)) ) THEN
WRITE (*, 10000)I, LCON (1, J), COOR (1, IP1),
& COOR (2, IP1), LCON (2, J), COOR (1, IP2),
& COOR (2, IP2)
130 CONTINUE
IF (ICOM.GT.JCOM)THEN
CALL FREFLD (IZ, IZ, 'NEW CONSTANT Y VALUE: ',
& MCOM, IOSTAT, JCOM, KIN, CIN, IIN, RIN)
ICOM=1
ENDIF
IF (KIN (ICOM).GT.0)THEN
COOR (2, IP1)=RIN (ICOM)
COOR (2, IP2)=RIN (ICOM)
ICOM=ICOM+1
ELSE
CALL MESSAGE('BAD INPUT - TRY AGAIN')
ICOM=ICOM+1
GOTO 130
ENDIF
ENDIF
ENDIF
140 CONTINUE
ELSE
CALL MESSAGE('DIRECTION MUST BE "X" OR "Y"')
ICOM=ICOM+1
ENDIF
ELSE
CALL MESSAGE(' ')
CALL MESSAGE('*------------------------------*')
CALL MESSAGE('NO LINES IN THE CURRENT DATABASE')
CALL MESSAGE('*------------------------------*')
RETURN
ENDIF
GOTO 100
10000 FORMAT (' LINE', I5, ' HAS THE FOLLOWING END POINTS:', /,
& ' POINT:', I5, ' X COORDINATE', G14.7, ' Y COORDINATE ',
& G14.7, /,
& ' POINT:', I5, ' X COORDINATE', G14.7, ' Y COORDINATE ',
& G14.7)
END