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 C======================================================================= SUBROUTINE RDINPT (TIMES,IDA,IDB,MP,SEABMP,IMP,MBLK) C ****************************************************************** C SUBROUTINE TO READ, CHECK AND PRINT INPUT DATA FROM STD-INPUT C BATCH TYPE EXECUTION IS ACCOMPLISHEDBY PIPING INPUT DATA C FROM A TEXT FILE; NORMALLY INPUT READ INTERACTIVELY. C INPUT IS READ UNDER A FREE FIELD FORMAT IN SUBROUTINE FREFLD C SUBROUTINE FREFLD IS PART OF THE EXTERNAL "SUPES" C LIBRARY (SAND86-0911) C Calls subroutines BANNR2, ERROR C Called by MAPVAR C ****************************************************************** include 'exodusII.inc' CHARACTER*10 CVAL include 'amesh.blk' include 'bmesh.blk' include 'contrl.blk' include 'ex2tp.blk' include 'rundat.blk' include 'schdat.blk' include 'steps.blk' include 'tapes.blk' include 'debg.blk' include 'inival.blk' DIMENSION KVALUE(8),CVAL(8),IVALUE(8),RVALUE(8) DIMENSION TIMES(*),IDA(*),IDB(*),MP(3,*) C search box size per map DIMENSION SEABMP(*) C ****************************************************************** MFIELD = 8 C PRINT RUN-TIME DATA WRITE (NOUT, 1000) WRITE (NTPOUT, 1000) CALL BANNR2 (84,QAINFO(1),NOUT) CALL BANNR2 (84,QAINFO(1),NTPOUT) WRITE (NOUT, 1010) WRITE (NTPOUT, 1010) WRITE (NOUT, 1020) QAINFO(3) WRITE (NTPOUT, 1020) QAINFO(3) WRITE (NOUT, 1030) QAINFO(5) WRITE (NTPOUT, 1030) QAINFO(5) WRITE (NOUT, 1040) QAINFO(6) WRITE (NTPOUT, 1040) QAINFO(6) WRITE (NOUT, 1050) WRITE (NTPOUT, 1050) C default map CALL EXGEBI(NTP2EX,IDA,IERR) CALL EXGEBI(NTP3EX,IDB,IERR) IMP = 0 IMP2 = 0 DO 2 I = 1, NBLKSB DO 3 J = 1, NBLKSA IF (IDB(I) .EQ. IDA(J))THEN IMP = IMP + 1 MP(1,IMP) = IDA(J) MP(2,IMP) = IDB(I) MP(3,IMP) = ISCHEM SEABMP(IMP) = -1.0 GO TO 2 END IF 3 CONTINUE 2 CONTINUE NUMTIM = EXINQI (NTP2EX,EXTIMS) CALL EXGATM (NTP2EX,TIMES,IERR) OUTTIM = -1. ISTEP = NUMTIM RTIME = TIMES(NUMTIM) 4 CONTINUE WRITE (NOUT, 1060) WRITE (NOUT, 1061) 5 CONTINUE CALL FREFLD (0,0,'CMD >',MFIELD,IOSTAT,NFIELD,KVALUE,CVAL, 1IVALUE,RVALUE) if (iostat .ne. 0) go to 100 if (nfield .eq. 0) go to 5 IF (KVALUE(1) .NE. 0) GO TO 10 if (cval(1)(1:1) .EQ. '#') go to 5 if (cval(1)(1:1) .EQ. '$') go to 5 IF (CVAL(1)(1:3) .EQ. 'HEL') GO TO 20 IF (CVAL(1)(1:3) .EQ. 'TIM') GO TO 30 IF (CVAL(1)(1:3) .EQ. 'STE') GO TO 35 IF (CVAL(1)(1:3) .EQ. 'OUT') GO TO 39 IF (CVAL(1)(1:3) .EQ. 'LIS') GO TO 40 IF (CVAL(1)(1:3) .EQ. 'SCH') GO TO 50 IF (CVAL(1)(1:3) .EQ. 'SEA') GO TO 60 IF (CVAL(1)(1:3) .EQ. 'INI') GO TO 65 IF (CVAL(1)(1:3) .EQ. 'DEF') GO TO 70 IF (CVAL(1)(1:3) .EQ. 'DEB') GO TO 75 IF (CVAL(1)(1:3) .EQ. 'MAP') GO TO 80 IF (CVAL(1)(1:3) .EQ. 'CHE') GO TO 89 IF (CVAL(1)(1:3) .EQ. 'STO') GO TO 90 IF (CVAL(1)(1:3) .EQ. 'QUI') GO TO 90 IF (CVAL(1)(1:3) .EQ. 'END') GO TO 100 IF (CVAL(1)(1:3) .EQ. 'EXI') GO TO 100 IF (CVAL(1)(1:3) .EQ. 'RUN') GO TO 100 10 CONTINUE C Bad input WRITE (NOUT,1100) CVAL(1) WRITE (NTPOUT,1100) CVAL(1) GO TO 5 20 CONTINUE C Help IF (NFIELD .EQ. 1)THEN GO TO 4 ELSE IF (CVAL(2)(1:3) .EQ. 'TIM') THEN WRITE(NOUT,2000) GO TO 5 ELSE IF (CVAL(2)(1:3) .EQ. 'LIS') THEN WRITE(NOUT,2010) GO TO 5 ELSE IF (CVAL(2)(1:3) .EQ. 'SCH') THEN WRITE(NOUT,2020) GO TO 5 ELSE IF (CVAL(2)(1:3) .EQ. 'DEF')THEN WRITE(NOUT,2030) WRITE(NOUT,2040) WRITE(NOUT,2045) GO TO 5 ELSE IF (CVAL(2)(1:3) .EQ. 'SEA')THEN WRITE(NOUT,2050) GO TO 5 ELSE IF (CVAL(2)(1:3) .EQ. 'MAP')THEN WRITE(NOUT,2060) GO TO 5 ELSE IF (CVAL(2)(1:3) .EQ. 'CHE')THEN WRITE(NOUT,2070) GO TO 5 END IF 30 CONTINUE C Time IF (KVALUE(2) .NE. 1 .AND. KVALUE(2) .NE. 2)THEN IF(CVAL(2)(1:3) .EQ. 'ALL')THEN ISTEP = -1 IDEF = 0 WRITE(NOUT,3000) GO TO 40 ELSE WRITE(NOUT,3010)CVAL(2) GO TO 5 END IF ELSE C convert time to closest time step RTIME = RVALUE(2) ISTEP = NUMTIM DO 32 I = 1, NUMTIM - 1 TMID = (TIMES(I) + TIMES(I + 1)) / 2. IF(TMID .GT. RTIME) THEN ISTEP = I GO TO 33 END IF 32 CONTINUE 33 WRITE(NOUT,3020)RTIME,TIMES(ISTEP),ISTEP GO TO 5 END IF 35 CONTINUE C Step IF (KVALUE(2) .NE. 1 .AND. KVALUE(2) .NE. 2)THEN IF(CVAL(2)(1:3) .EQ. 'ALL')THEN ISTEP = -1 IDEF = 0 WRITE(NOUT,3005) GO TO 40 ELSE WRITE(NOUT,3015)CVAL(2) GO TO 5 END IF ELSE ISTEP = IVALUE(2) WRITE(NOUT,3025)ISTEP,TIMES(ISTEP) GO TO 5 END IF 39 CONTINUE C output time IF (ISTEP .EQ. -1)THEN WRITE(NOUT,3040) GO TO 5 END IF IF (KVALUE(2) .EQ. 0)THEN IF (KVALUE(3) .EQ. 1 .OR. KVALUE(3) .EQ. 2)THEN OUTTIM = RVALUE(3) END IF ELSE IF (KVALUE(2) .EQ. 1 .OR. KVALUE(2) .EQ. 2)THEN OUTTIM = RVALUE(2) ELSE WRITE(NOUT,3030)CVAL(2),CVAL(3) END IF GO TO 5 40 CONTINUE C List times WRITE (NOUT,4000) WRITE (NOUT,4010)(TIMES(I),I=1,NUMTIM) GO TO 5 50 CONTINUE C Scheme IF (KVALUE(2) .NE. 2)THEN WRITE(NOUT,5000)CVAL(2) GO TO 5 END IF ISCHEM = IVALUE(2) DO 55 I = 1, IMP MP(3,I) = ISCHEM 55 CONTINUE IF (ISCHEM .EQ. 0)THEN WRITE(NOUT,5010)ISCHEM ELSE IF (ISCHEM .EQ. 1)THEN WRITE(NOUT,5020)ISCHEM ELSE IF (ISCHEM .EQ. 2)THEN WRITE(NOUT,5030)ISCHEM ELSE IF (ISCHEM .EQ. 3)THEN WRITE(NOUT,5035)ISCHEM ELSE WRITE(NOUT,5040)ISCHEM END IF GO TO 5 60 CONTINUE C Searchbox (tolerance) C Searchbox toler_shell, toler_quad, toler_hex, toler_tet if (nfield .eq. 2) then IF (KVALUE(2) .EQ. 1 .OR. KVALUE(2) .EQ. 2) THEN TOLSHL = RVALUE(2) TOLTET = RVALUE(2) TOLQAD = RVALUE(2) TOLHEX = RVALUE(2) if (tolshl .ge. 1.0) then WRITE(NOUT,6000) TOLSHL WRITE(NTPOUT,6000) TOLSHL else WRITE(NOUT,6001)'Overall', TOLSHL WRITE(NTPOUT,6001)'Overall', TOLSHL end if ELSE WRITE(NOUT,6010)CVAL(2) END IF GO TO 5 else if (nfield .eq. 3) then IF (KVALUE(3) .NE. 1 .AND. KVALUE(3) .NE. 2) THEN WRITE(NOUT,6011) CVAL(2), 3, CVAL(3) go to 5 end if if (CVAL(2)(:1) .eq. 'H' .or. CVAL(2)(:1) .eq. 'h') THEN TOLHEX = RVALUE(3) WRITE(NOUT,6001) CVAL(2), TOLHEX WRITE(NTPOUT,6001) CVAL(2), TOLHEX else if (CVAL(2)(:1) .eq. 'S' .or. CVAL(2)(:1) .eq. 's') THEN TOLSHL = RVALUE(3) WRITE(NOUT,6001) CVAL(2), TOLSHL WRITE(NTPOUT,6001) CVAL(2), TOLSHL else if (CVAL(2)(:1) .eq. 'T' .or. CVAL(2)(:1) .eq. 't') THEN TOLTET = RVALUE(3) WRITE(NOUT,6001) CVAL(2), TOLTET WRITE(NTPOUT,6001) CVAL(2), TOLTET else if (CVAL(2)(:1) .eq. 'Q' .or. CVAL(2)(:1) .eq. 'q') THEN TOLQAD = RVALUE(3) WRITE(NOUT,6001) CVAL(2), TOLQAD WRITE(NTPOUT,6001) CVAL(2), TOLQAD end if GO TO 5 end if 65 CONTINUE C Initial Value (value) IF (KVALUE(3) .EQ. 1 .OR. KVALUE(3) .EQ. 2) THEN VALINI = RVALUE(3) WRITE(NOUT,6501) VALINI WRITE(NTPOUT,6501) VALINI ELSE WRITE(NOUT,6510) CVAL(3) END IF GO TO 5 70 CONTINUE C Deformed vs undeformed processing IF (KVALUE(2) .NE. 2)THEN WRITE(NOUT,7000)CVAL(2) GO TO 5 END IF IDEF = IVALUE(2) IF (IDEF .EQ. 0)THEN WRITE(NOUT,7010)idef ELSE IF (IDEF .EQ. 1 .OR. IDEF .EQ. 2)THEN IF (ISTEP .EQ. -1)THEN WRITE(NOUT,7020)idef IDEF = 0 END IF IF (IDEF .EQ. 1)THEN WRITE(NOUT,7030)idef ELSE IF (IDEF .EQ. 2) THEN WRITE(NOUT,7035)idef END IF ELSE WRITE(NOUT,7040)idef END IF GO TO 5 75 CONTINUE C Debug output IF (KVALUE(2) .NE. 2)THEN WRITE(NOUT,7005)CVAL(2) GO TO 5 END IF IDEBUG = IVALUE(2) WRITE(NOUT,7006) IDEBUG WRITE(NTPOUT,7006) IDEBUG GO TO 5 80 CONTINUE C Map definition - donor mesh e-block to recipient mesh e-block if (nfield .eq. 2 .and. cval(2)(1:3) .eq. 'RES') then C ... Reset to no block mappings. IMP = 0 IMP2 = 0 write(nout,8000) go to 5 end if C save global scheme value ISCHEC = ISCHEM IF (KVALUE(2) .EQ. 0 .AND. CVAL(2) .EQ. 'ALL')THEN IF (CVAL(3) .NE. 'TO')THEN WRITE(NOUT,8010) WRITE(NTPOUT,8010) GO TO 5 END IF IF (KVALUE(4) .NE. 1 .AND. KVALUE(4) .NE. 2)THEN WRITE(NOUT,8020)CVAL(4) WRITE(NTPOUT,8020)CVAL(4) GO TO 5 END IF IF (KVALUE(5) .EQ. 0 .AND. CVAL(5)(1:3) .EQ. 'SCH' .AND. & (KVALUE(6) .EQ. 1 .OR. KVALUE(6) .EQ. 2))THEN IF (IVALUE(6) .GE. 0 .AND. IVALUE(6) .LE. 3) THEN ISCHEM = IVALUE(6) END IF END IF IF (KVALUE(7) .EQ. 0 .AND. CVAL(7)(1:3) .EQ. 'SCH' .AND. & (KVALUE(8) .EQ. 1 .OR. KVALUE(8) .EQ. 2))THEN IF (IVALUE(8) .GE. 0 .AND. IVALUE(8) .LE. 3) THEN ISCHEM = IVALUE(8) END IF END IF C process input for search box size for this map SEABOX = -1.0 IF ( ( KVALUE( 5) .EQ. 0) .AND. & ( CVAL( 5)(1:3) .EQ. 'SEA')) THEN IF ( KVALUE( 6) .EQ. 1) THEN SEABOX = RVALUE( 6) ELSE IF ( KVALUE( 6) .EQ. 2) THEN SEABOX = IVALUE( 6) END IF END IF IF ( ( KVALUE( 7) .EQ. 0) .AND. & ( CVAL( 7)(1:3) .EQ. 'SEA')) THEN IF ( KVALUE( 8) .EQ. 1) THEN SEABOX = RVALUE( 8) ELSE IF ( KVALUE( 8) .EQ. 2) THEN SEABOX = IVALUE( 8) END IF END IF C ... Check for valid id ID = IVALUE(4) idl = locint(id, nblksb, idb) if (idl .eq. 0) then write (nout, 8090) id ISCHEM = ISCHEC go to 5 end if DO 82 I = 1, NBLKSA MP(1,I+IMP2) = IDA(I) MP(2,I+IMP2) = IVALUE(4) MP(3,I+IMP2) = ISCHEM SEABMP(I+IMP2) = SEABOX 82 CONTINUE IMP2 = IMP2 + NBLKSA IMP = IMP2 WRITE(NOUT,8040) call pmap(imp, mp, seabmp, nout) C restore global scheme value ISCHEM = ISCHEC GO TO 5 ELSE IF (KVALUE(4) .EQ. 0 .AND. CVAL(4) .EQ. 'ALL')THEN IF (CVAL(3) .NE. 'TO')THEN WRITE(NOUT,8010) WRITE(NTPOUT,8010) GO TO 5 END IF IF (KVALUE(2) .NE. 1 .AND. KVALUE(2) .NE. 2)THEN WRITE(NOUT,8030)CVAL(2) WRITE(NTPOUT,8030)CVAL(2) GO TO 5 END IF IF (KVALUE(5) .EQ. 0 .AND. CVAL(5)(1:3) .EQ. 'SCH' .AND. & (KVALUE(6) .EQ. 1 .OR. KVALUE(6) .EQ. 2))THEN IF (IVALUE(6) .GE. 0 .AND. IVALUE(6) .LE. 3) THEN ISCHEM = IVALUE(6) END IF END IF IF (KVALUE(7) .EQ. 0 .AND. CVAL(7)(1:3) .EQ. 'SCH' .AND. & (KVALUE(8) .EQ. 1 .OR. KVALUE(8) .EQ. 2))THEN IF (IVALUE(8) .GE. 0 .AND. IVALUE(8) .LE. 3) THEN ISCHEM = IVALUE(8) END IF END IF C process input for search box size for this map SEABOX = -1.0 IF ( ( KVALUE( 5) .EQ. 0) .AND. & ( CVAL( 5)(1:3) .EQ. 'SEA')) THEN IF ( KVALUE( 6) .EQ. 1) THEN SEABOX = RVALUE( 6) ELSE IF ( KVALUE( 6) .EQ. 2) THEN SEABOX = IVALUE( 6) END IF END IF IF ( ( KVALUE( 7) .EQ. 0) .AND. & ( CVAL( 7)(1:3) .EQ. 'SEA')) THEN IF ( KVALUE( 8) .EQ. 1) THEN SEABOX = RVALUE( 8) ELSE IF ( KVALUE( 8) .EQ. 2) THEN SEABOX = IVALUE( 8) END IF END IF C ... Check for valid id ID = IVALUE(2) idl = locint(id, nblksa, ida) if (idl .eq. 0) then write (nout, 8090) id ischem = ischec go to 5 end if DO 84 I = 1, NBLKSB MP(2,I+IMP2) = IDB(I) MP(1,I+IMP2) = IVALUE(2) MP(3,I+IMP2) = ISCHEM SEABMP(I+IMP2) = SEABOX 84 CONTINUE IMP2 = IMP2 + NBLKSB IMP = IMP2 WRITE(NOUT,8040) call pmap(imp, mp, seabmp, nout) ISCHEM = ISCHEC GO TO 5 ELSE IF (KVALUE(2) .EQ. 1 .OR. KVALUE(2) .EQ. 2 .AND. & KVALUE(4) .EQ. 1 .OR. KVALUE(4) .EQ. 2)THEN IF (CVAL(3) .NE. 'TO')THEN WRITE(NOUT,8010) WRITE(NTPOUT,8010) GO TO 5 END IF IF (KVALUE(5) .EQ. 0 .AND. CVAL(5)(1:3) .EQ. 'SCH' .AND. & (KVALUE(6) .EQ. 1 .OR. KVALUE(6) .EQ. 2))THEN IF (IVALUE(6) .GE. 0 .AND. IVALUE(6) .LE. 3) THEN ISCHEM = IVALUE(6) END IF END IF IF (KVALUE(7) .EQ. 0 .AND. CVAL(7)(1:3) .EQ. 'SCH' .AND. & (KVALUE(8) .EQ. 1 .OR. KVALUE(8) .EQ. 2))THEN IF (IVALUE(8) .GE. 0 .AND. IVALUE(8) .LE. 3) THEN ISCHEM = IVALUE(8) END IF END IF C process input for search box size for this map SEABOX = -1.0 IF ( ( KVALUE( 5) .EQ. 0) .AND. & ( CVAL( 5)(1:3) .EQ. 'SEA')) THEN IF ( KVALUE( 6) .EQ. 1) THEN SEABOX = RVALUE( 6) ELSE IF ( KVALUE( 6) .EQ. 2) THEN SEABOX = IVALUE( 6) END IF END IF IF ( ( KVALUE( 7) .EQ. 0) .AND. & ( CVAL( 7)(1:3) .EQ. 'SEA')) THEN IF ( KVALUE( 8) .EQ. 1) THEN SEABOX = RVALUE( 8) ELSE IF ( KVALUE( 8) .EQ. 2) THEN SEABOX = IVALUE( 8) END IF END IF C ... Check for valid ids ID = IVALUE(2) idl = locint(id, nblksa, ida) if (idl .eq. 0) then write (nout, 8090) id ischem = ischec go to 5 end if ID = IVALUE(4) idl = locint(id, nblksb, idb) if (idl .eq. 0) then write (nout, 8090) id ischem = ischec go to 5 end if IMP2 = IMP2 + 1 if (imp2 .gt. mblk) then CALL ERROR('RDINPT','Too many block mappings entered', $ 'Entered', imp2,'Maximum',mblk,' ',' ',1) end if IMP = IMP2 MP(1,IMP2) = IVALUE(2) MP(2,IMP2) = IVALUE(4) MP(3,IMP2) = ISCHEM SEABMP(IMP2) = SEABOX WRITE(NOUT,8040) call pmap(imp, mp, seabmp, nout) WRITE(NOUT,8070) DO 88 I = 1, NBLKSB WRITE(NOUT,8080)IDB(I) 88 CONTINUE ischem = ischec GO TO 5 ELSE WRITE(NOUT,8060)CVAL(2) WRITE(NTPOUT,8060)CVAL(2) GO TO 5 END IF 89 CONTINUE C Read integer flag for accuracy checks (comparison of C various quantities between donor and recipient meshes IF (KVALUE(2) .NE. 2) THEN WRITE (NOUT,8900)CVAL(2) WRITE (NTPOUT,8900)CVAL(2) GO TO 5 END IF IACCU = IVALUE(2) IF (IACCU .EQ. 0)THEN WRITE(NOUT,8910)IACCU WRITE(NTPOUT,8910)IACCU ELSE IF (IACCU .EQ. 1)THEN WRITE(NOUT,8920)IACCU WRITE(NTPOUT,8920)IACCU ELSE WRITE(NOUT,8930)IACCU WRITE(NTPOUT,8930)IACCU END IF GO TO 5 90 CONTINUE C Stop execution WRITE(NOUT,9000) WRITE(NTPOUT,9000) CALL ERROR('RDINPT','YOU ELECTED TO TERMINATE THE PROGRAM',' ', & 0,' ',0,' ',' ',1) 100 CONTINUE C Continue execution (run) C sort map array (MP) on second entry (recipient mesh element block) C this is required because of way mapping of multiple donor mesh C element blocks into one recipient mesh element blocks is C implemented (required to have all such maps located sequentially) C a simple sort on the 2nd entry accomplishes this and is easier C than rewriting the offending algorithm IBOTOM = IMP - 1 110 ISWICH = 1 DO 120 I = 1, IBOTOM IF (MP(2,I) .LE. MP(2,I+1))THEN GO TO 120 ELSE ITEMP = MP(1,I) MP(1,I) = MP(1,I+1) MP(1,I+1) = ITEMP ITEMP = MP(2,I) MP(2,I) = MP(2,I+1) MP(2,I+1) = ITEMP ITEMP = MP(3,I) MP(3,I) = MP(3,I+1) MP(3,I+1) = ITEMP RTEMP = SEABMP(I) SEABMP(I) = SEABMP(I+1) SEABMP(I+1) = RTEMP ISWICH = I GO TO 120 END IF 120 CONTINUE IF (ISWICH .EQ. 1)THEN GO TO 130 ELSE IBOTOM = ISWICH - 1 GO TO 110 END IF 130 CONTINUE C end sort WRITE(NOUT,10000) WRITE(NTPOUT,10000) IF (ISTEP .EQ. -1) THEN WRITE(NOUT,10010) WRITE(NTPOUT,10010) ELSE WRITE(NOUT,10020)RTIME,TIMES(ISTEP),ISTEP WRITE(NTPOUT,10020)RTIME,TIMES(ISTEP),ISTEP END IF IF (IDEF .EQ. 0)THEN WRITE(NOUT,7010)idef WRITE(NTPOUT,7010)idef ELSE IF (IDEF .EQ. 1)THEN WRITE(NOUT,7030)idef WRITE(NTPOUT,7030)idef ELSE IF (IDEF .EQ. 2) THEN WRITE(NOUT,7035)idef WRITE(NTPOUT,7035)idef END IF IF (ISCHEM .EQ. 0)THEN WRITE(NOUT,5010)ISCHEM WRITE(NTPOUT,5010)ISCHEM ELSE IF (ISCHEM .EQ. 2)THEN WRITE(NOUT,5030)ISCHEM WRITE(NTPOUT,5030)ISCHEM ELSE IF (ISCHEM .EQ. 3)THEN WRITE(NOUT,5035)ISCHEM WRITE(NTPOUT,5035)ISCHEM ELSE WRITE(NOUT,5020)ISCHEM WRITE(NTPOUT,5020)ISCHEM END IF WRITE(NOUT,10030) WRITE(NTPOUT,10030) call pmap(imp, mp, seabmp, nout) call pmap(imp, mp, seabmp, ntpout) RETURN 1000 FORMAT ('1',/////) 1010 FORMAT (//,5X,'*************************************************** 1********',//) 1020 FORMAT (5X,'VERSION -- ',A32,//) 1030 FORMAT (5X,'DATE OF EXECUTION -- ',A32,//) 1040 FORMAT (5X,'TIME OF EXECUTION -- ',A32,//) 1050 FORMAT (2X,'READING INPUT DATA' ,//) 1060 FORMAT (5X,'MAPVAR INPUT - SYNTAX:',/,' KEY_WORD ',//, 1' HELp - REPEATS THIS MESSAGE',/, 2' HELp - DESCRIPTION OF COMMAND - key_word',/, 3' SCHeme - MAPPING SCHEME TO USE',/, 4' DEFormed - ORIGINAL OR DEFORMED GEOMETRY',/, 5' LISt TIMes - WRITES A LIST OF TIMES AVAILABLE',/, 6' TIMes - TIME TO BE MAPPED',/, 7' STEp - TIME STEP TO BE MAPPED',/, 8' OUTput TIMe - TIME TO BE WRITTEN TO OUTPUT FILE',/, 9' SEArchbox - SEARCH BOX TO BE USED') 1061 FORMAT ( *' MAP TO ',/, 1 ' MAP TO SCHeme ',/, * ' MAP TO SEArchbox ',/, *' MAP TO SCHeme ', *' SEArchbox ',/, *' MAP TO SEArchbox ', *' SCHeme ',/, *' DEBUG 0,1,2,3 - CONTROL DEBUG OUTPUT',/, *' INITIAL VALUE - SPECIFY VALUE USED TO INIT VARS',/, 2' - ELEMENT BLOCK MAPPING ',/, 3' CHEck - CHECK ACCURACY OF MAPPING',/, 3' RUN - END INPUT - RESUME PROGRAM',/, 3' QUIT - TERMINATES THE PROGRAM',/, 4' STOP - TERMINATES THE PROGRAM') 1100 FORMAT(5X,'UNKNOWN INPUT - READING',A20,/, 1' PLEASE TRY AGAIN') 2000 FORMAT(5X,'TIMe ',//, 1' IF A REAL NUMBER VALUE IS ENTERED, IT REPRESENTS',/, 2' THE TIME (STEP) SELECTED AT WHICH VARIABLES WILL',/, 3' BE MAPPED FROM THE DONOR TO THE RECIPIENT MESH',/, 4' DEFAULT - the last time step in restart file',/, 5' IF *ALL* IS ENTERED, ALL THE TIME STEPS IN THE',/, 6' DONOR MESH WILL BE MAPPED.',/, 7' NOTE: ONLY ORIGINAL GEOMETRY MAPPING IS ALLOWED',/, 8' *DEFORMED 0*') 2010 FORMAT(5x,'LISt TIMes',//, 1' LIST TIMES COMMAND READS THE DONOR MESH FILE',/, 2' AND ECHOS TO THE CRT A LIST OF TIMES AVAILABLE TO',/, 3' THE USER.',//, 4' DEFAULT - none') 2020 FORMAT(5x,'SCHeme ',//, 1' SCHEME COMMAND PICKS THE MAPPING SCHEME TO USE',/, 2' SCHEME 0 - NODAL BASED SIMPLE INTERPOLATION',/, 3' SCHEME 1 - NODAL BASED LEAST SQUARES',/, 4' SCHEME 2 - DIRECT TRANSFER',/, 5' SCHEME 3 - ELEMENT CENTROID BASED LEAST SQUARES',/, 7' DEFAULT - 1') 2030 FORMAT(5X,'DEFormed ',//, 1' THE DEFORMED COMMAND SELECTS USE OF ORIGINAL OR',/, 2' DEFORMED GEOMETRY',/, 3' DEFORMED 0 - ORIGINAL GEOMETRY - COORDINATES ARE',/, 4' NOT MODIFIED BY DISPLACEMENTS',/, 5' RECIPIENT MESH BOUNDARIES IDENTICAL',/, 6' TO UNDEFORMED DONOR MESH BOUNDARIES') 2040 FORMAT(10X,'DEFORMED 1 - DEFORMED GEOMETRY - DISPLACEMENTS ARE',/, 1' ADDED TO DONOR MESH COORDINATES PRIOR',/, 2' TO USE AND THE MAPPED DISPLACEMENTS',/, 3' ARE SUBTRACTED FROM RECIPIENT MESH',/, 4' COORDINATES PRIOR TO OUTPUT',/, 5' RECIPIENT MESH BOUNDARIES IDENTICAL',/, 6' TO DEFORMED DONOR MESH BOUNDARIES') 2045 FORMAT(10X,'DEFORMED 2 - MESH ANNEALING - MAP IS PERFORMED IN',/, 1' DEFORMED COORDINATES (DISPLACEMENTS',/, 2' ARE ADDED TO DONOR MESH COORDINATES',/, 3' PRIOR TO USE. OUTPUT DISPLACEMENTS',/, 4' ARE SET TO ZERO.',/, 5' THIS OPTION WAS REQUESTED FOR GOMA',/, 6' DEFAULT - 1') 2050 FORMAT(10X,'SEArchbox ',/, *' SEArchbox SHELL ',/, *' SEArchbox HEX ',/, *' SEArchbox QUAD ',/, *' SEArchbox TET ',//, 1' THE SEARCHBOX IS A BOUNDING BOX AROUND THE DONOR',/, 2' MESH ELEMENT OR GROUP OF ELEMENTS IN WHICH THE',/, 3' SEARCH ROUTINE ATTEMPTS TO FIND A POINT',/, 4' (RECIPIENT MESH NODE OR ELEMENT CENTROID).',/, 5' THE SEARCH BOX CAN BE INCREASED MODESTLY',/, 5' TO OVERCOME MESHING ISSUES - AS DIFFERENT',/, 6' DISCRETIZATION ON A RADIUS.',/, 7' BE GENTLE - INCREASE CAN HAVE A LARGE EFFECT ON',/, 8' RUN TIMES. GREATER THAN 1.0 IS NOT RECOMMENDED.',/, 9' DEFAULT = 0.01') 2060 FORMAT(10X,'MAP TO ',/, 1 ' MAP TO SCHeme ',/, 2 ' MAP TO SEArchbox ',/, 4 ' MAP TO SCHeme ', *' SEArchbox ',/, 5 ' MAP TO SEArchbox ', *' SCHeme ',//, 6' THE MAP COMMAND ALLOWS THE USER TO DEFINE THE',/, 7' DONOR MESH ELEMENT BLOCK I.D. TO BE MAPPED INTO',/, 8' THE RECIPIENT MESH ELEMENT BLOCK I.D. ALONG WITH',/, 9' THE SCHEME AND SEARCHBOX TO USE FOR THIS MAPPING.',/, *' IF THE VALUE "ALL" IS ENTERED THE OTHER BLOCK I.D.',/, *' FIELD MUST CONTAIN AN INTEGER. THE SCHEME AND',/, *' SEARCHBOX VALUES ARE OPTIONAL. SPECIFYING',/, *' SEARCHBOX > 0 WILL OVERRIDE THE GLOBAL SEARCHBOX',/, *' SETTING FOR THIS MAP ONLY.',/, *' DEFAULT:',/, *' 1 TO 1 2 TO 2 ETC',/, *' DEFAULT SCHEME value entered with SCH command or 1',/, *' DEFAULT SEARCHBOX is no override of global setting',/, *' global SEARCHBOX setting is default 0.01 or value',/, *' entered using SEARCHBOX COMMAND') 2070 FORMAT(10X,'CHEck ',//, 1' THE CHECK COMMAND COMPUTES QUANTITIES FOR',/, 2' COMPARISON BETWEEN THE DONOR AND RECIPIENT',/, 3' MESHES',/, 4' 0 - NO CHECK QUANTITIES COMPUTED',/, 5' 1 - ALL APPROPRIATE QUANTITIES COMPUTED',/, 6' DEFAULT - 0') 3000 FORMAT(5X,'TIME YOU HAVE ENTERED - TIMES ALL',/, 1' ALL THE TIME STEPS WILL BE MAPPED',/, 2' ONLY UNDEFORMED GEOMETRY PROCESSING IS',/, 3' IMPLEMENTED WITH *TIMES ALL* TIME STEP INPUT',/, 4' DEFORMED 0',///) 3005 FORMAT(5X,'STEP YOU HAVE ENTERED - STEPS ALL',/, 1' ALL THE TIME STEPS WILL BE MAPPED',/, 2' ONLY UNDEFORMED GEOMETRY PROCESSING IS',/, 3' IMPLEMENTED WITH *STEPS ALL* TIME STEP INPUT',/, 4' DEFORMED 0',///) 3010 FORMAT(5X,'READING TIMES COMMAND',/, 1' EXPECTED A REAL NUMBER IN FIELD 2',/, 2' READ',A20,/, 3' PLEASE TRY AGAIN') 3015 FORMAT(5X,'READING STEP COMMAND',/, 1' EXPECTED A REAL NUMBER IN FIELD 2',/, 2' READ',A20,/, 3' PLEASE TRY AGAIN') 3020 FORMAT(5X,'TIME YOU HAVE ENTERED',F14.6,/, 1' CLOSEST TIME ON DATABASE',F14.6,/, 2' TIME STEP',I5,///) 3025 FORMAT(5X,'STEP YOU HAVE ENTERED',I3,/, 1' TIME ',F14.6,///) 3030 FORMAT(5X,'READING OUTPUT TIME COMMAND',/, 1' EXPECTED A REAL NUMBER IN FIELD 2 OR 3',/, 2' READ',A20,A20,/, 3' PLEASE TRY AGAIN') 3040 FORMAT(5X,'YOU HAVE ALREADY SELECTED TO PROCESS',/, 1' ALL TIME STEPS AVAILABLE. YOU CANNOT ALSO',/, 2' CHANGE THE OUTPUT TIME') 4000 FORMAT(5X,'TIMES AVAILABLE FROM THE RESTART FILE') 4010 FORMAT(5X,/,E14.6) 5000 FORMAT(5X,'READING SCHEME COMMAND',/, 1' EXPECTED AN INTEGER IN FIELD 2',/, 2' READ',A20,/, 3' PLEASE TRY AGAIN') 5010 FORMAT(//,5X,'YOU HAVE ENTERED SCHEME ',I5,/, 1' NODAL BASED SIMPLE INTERPOLATION') 5020 FORMAT(//,5X,'YOU HAVE ENTERED SCHEME ',I5,/, 1' NODAL BASED LEAST SQUARES') 5030 FORMAT(//,5X,'YOU HAVE ENTERED SCHEME ',I5,/, 1' DIRECT TRANSFER') 5035 FORMAT(//,5X,'YOU HAVE ENTERED SCHEME ',I5,/, 1' ELEMENT CENTROID BASED LEAST SQUARES') 5040 FORMAT(5X,'YOU HAVE ENTERED SCHEME ',I5,/, 1' THIS SCHEME HAS NOT BEEN IMPLEMENTED',/, 2' PLEASE TRY AGAIN') 6000 FORMAT(//,5X,'YOU HAVE ENTERED SEARCH ',F12.4,/, 1' VALUES GREATER THAN 1. ARE NOT RECOMMENDED') 6001 FORMAT(//,5X,A,' Search Tolerance is ',F12.4) 6010 FORMAT(5X,'READING SEArch COMMAND',/, 1' EXPECTED A REAL NUMBER IN FIELD 2',/, 2' READ',A20,/, 3' PLEASE TRY AGAIN') 6011 FORMAT(5X,'READING SEArch ',A,' COMMAND',/, 1' EXPECTED A REAL NUMBER IN FIELD ', I1,/, 2' READ',A20,/, 3' PLEASE TRY AGAIN') 6501 FORMAT(//,5X,'Initial Value is ',1Pe12.4) 6510 FORMAT(5X,'READING INItial Value COMMAND',/, 1' EXPECTED A REAL NUMBER IN FIELD 3',/, 2' READ',A20,/, 3' PLEASE TRY AGAIN') 7000 FORMAT(5X,'READING DEFORMED GEOMETRY COMMAND',/, 1' EXPECTED AN INTEGER IN FIELD 2',/, 2' READ',A20,/, 3' PLEASE TRY AGAIN') 7005 FORMAT(5X,'READING DEBUG OUTPUT COMMAND',/, 1' EXPECTED AN INTEGER IN FIELD 2',/, 2' READ',A20,/, 3' PLEASE TRY AGAIN') 7006 FORMAT(//,5X,'YOU HAVE ENTERED - DEBUG',I5,/) 7010 FORMAT(//,5X,'YOU HAVE ENTERED - DEFORMED',I5,/, 1' ORIGINAL GEOMETRY - COORDINATES ARE NOT',/, 2' MODIFIED BY DISPLACEMENTS') 7020 FORMAT(5X,'YOU HAVE ENTERED - DEFORMED',I5,/, 1' ONLY ORIGINAL GEOMETRY PROCESSING IS',/, 2' COMPATIBLE WITH *TIMES ALL* TIME STEP INPUT',/, 3' DEFORMED 0',///) 7030 FORMAT(//,5X,'YOU HAVE ENTERED - DEFORMED',I5,/, 1' DEFORMED GEOMETRY - DISPLACEMENTS ARE',/, 2' ADDED TO DONOR MESH COORDINATES AND',/, 3' SUBTRACTED FROM RECIPIENT MESH COORDINATES') 7035 FORMAT(//,5X,'YOU HAVE ENTERED - DEFORMED',I5,/, 1' MESH ANNEALING - DISPLACEMENTS ARE',/, 2' ADDED TO DONOR MESH COORDINATES.',/, 3' DISPLACEMENTS ARE ZERO ON THE INTERPOLATED MESH.') 7040 FORMAT(//,5X,'YOU HAVE ENTERED - DEFORMED',I5,/, 1' value - MUST BE EITHER 0 OR 1',/, 2' PLEASE TRY AGAIN') 8000 FORMAT(5x,'Reset all block mappings.') 8010 FORMAT(5X,'READING MAP COMMAND',/, &' EXPECTING THE CHARACTER STRING "TO" ',/, &' COMMAND SYNTAX IS:',/, &' MAP TO ',//, &' PLEASE TRY AGAIN') 8020 FORMAT(5X,'READING MAP COMMAND',/, &' EXPECTING AN INTEGER AFTER "MAP ALL TO"',/, &' READ',A20,/, &' PLEASE TRY AGAIN') 8030 FORMAT(5X,'READING MAP COMMAND',/, &' EXPECTING AN INTEGER IN FIELD 2 OF COMMAND',/, &' "MAP ?? TO ALL"',/, &' READ',A20,/, &' PLEASE TRY AGAIN') 8040 FORMAT(5X,/,'MAP AS ENTERED SO FAR IS:') 8060 FORMAT(5X,'READING MAP COMMAND',/, &' EXPECTING EITHER AN INTEGER OR THE STRING "ALL"',/, &' READ',A20,/, &' PLEASE TRY AGAIN') 8070 FORMAT(//,5X,'AVAILABLE RECIPIENT MESH ELEMENT BLOCK I.D.') 8080 FORMAT(10X,I7) 8090 FORMAT(//,5x,'ERROR: The entered id ', i5, * ' is not a valid block id.',/) 8900 FORMAT(5X,'READING CHECK ACCURACY COMMAND',/, 1' EXPECTED AN INTEGER IN FIELD 2',/, 2' READ',A20,/, 3' PLEASE TRY AGAIN') 8910 FORMAT(//,5X,'YOU HAVE ENTERED - CHECK',I5,/, 1' NO ACCURACY CHECKING WILL BE DONE') 8920 FORMAT(//,5X,'YOU HAVE ENTERED - CHECK',I5,/, 1' ALL APPROPRIATE QUANTITIES WILL BE COMPUTED',/, 2' AND WRITTEN TO THE TEXT OUTPUT FILE FOR',/, 3' COMPARISON BETWEEN THE DONOR AND RECIPIENT MESHES') 8930 FORMAT(//,5X,'YOU HAVE ENTERED - CHECK',I5,/, 1' ONLY VALUES 0 OR 1 HAVE BEEN IMPLEMENTED') 9000 FORMAT(5X,'YOU HAVE ELECTED TO TERMINATE THE PROGRAM',/, 1' NOTHING WILL BE COMPUTED OR SAVED') 10000 FORMAT(5X,'LEAVING RDINPT - VALUES USED ARE:',//) 10010 FORMAT(//5X,'YOU HAVE ENTERED FOR THE TIMES COMMAND',/, 1' *TIMES ALL* - ALL TIME STEPS WILL BE MAPPED',//) 10020 FORMAT(//5X,'YOU HAVE ENTERED FOR THE TIMES COMMAND',/, 1' rtime = ',F14.6,/, 2' CLOSEST TIME ON DATABASE',/, 3' ctime = ',f14.6,/, 4' TIME STEP',/, 5' istep =',i5,//) 10030 FORMAT(5X,'MAP TO BE USED:') END subroutine pmap(imp, mp, seabmp, nout) DIMENSION MP(3,*), SEABMP(*) DO 86 I = 1, IMP IF ( SEABMP( I) .GT. 0.0) THEN WRITE(NOUT,8051)MP(1,I),MP(2,I),MP(3,I),SEABMP(I) ELSE WRITE(NOUT,8050)MP(1,I),MP(2,I),MP(3,I) END IF 86 CONTINUE 8050 FORMAT(5X,'MAP ',I5,' TO', I5, ' SCHEME', I5) 8051 FORMAT(5X,'MAP ',I5,' TO', I5, ' SCHEME', I5,' SEARCHBOX', F14.6) return end