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.
144 lines
5.2 KiB
144 lines
5.2 KiB
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
|
|
|