* Set of subroutines to interface to the VLBLIB subroutine KEYIN(2) * DFB 05.05.88 Created * DFB 12.09.88 modified to standard Fortran 77 * DFB 26.04.91 At last we have SETKEYS and KEYRDS! * Routines available: * * CLRKEYS: (Re)initialise common block * * SETKEYI: Initialise an integer parameter * SETKEYR: Initialise a real*4 parameter * SETKEYD: Initialise a real*8 parameter * SETKEYC: Initialise a character parameter * SETKEYS: Initialise a string parameter * * INKEYS : Interact with user via keyin (kept in KEYIN.F) * * KEYRDI: Read back an integer parameter * KEYRDR: Read back a real*4 parameter * KEYRDD: Read back a real*8 parameter * KEYRDC: Read back a character parameter * KEYRDS: Read back a string parameter * SUBROUTINE CLRKEYS * ==================== IMPLICIT UNDEFINED (A-Z) INCLUDE "keydefs.inc" NPARS=0 END SUBROUTINE SETKEY(NAME,NPER,INIT,NELS,UNSET) * ============================================ * Sets up table for KEYIN. * Called by SETKEYI,SETKEYR,SETKEYD,SETKEYC,SETKEYL IMPLICIT UNDEFINED (A-Z) INCLUDE "keydefs.inc" CHARACTER*(*)NAME LOGICAL UNSET REAL*8 INIT(*) INTEGER NLEN,NELS,IEL,J,NPER CHARACTER*8 CTEMP,BLANK8,UNSET8 PARAMETER(BLANK8=' ',UNSET8='***UNSET') NLEN=LEN(NAME) IF(NLEN.GT.8)THEN IF(NAME(9:).NE.' ')PRINT*,'**Name ',NAME,' truncated' ENDIF CTEMP=NAME * Set up INIT if we want the values UNSET IF(UNSET)THEN INIT(1)=C8TOR8(UNSET8) DO 5 IEL=2,NPER*NELS 5 INIT(IEL)=C8TOR8(BLANK8) ENDIF DO 10 IEL=1,NELS NPARS=NPARS+1 PARS(NPARS)=CTEMP VALS(NPARS)=INIT(IEL*NPER-NPER+1) DO 10 J=2,NPER NPARS=NPARS+1 PARS(NPARS)=BLANK8 VALS(NPARS)=INIT(IEL*NPER-NPER+J) 10 CONTINUE IF(NPARS.GT.NPMAX)PRINT*,'**Too many parameters' END SUBROUTINE SETKEYI(NAME,VAL,NELS,UNSET) * ================================ IMPLICIT UNDEFINED (A-Z) CHARACTER*(*)NAME LOGICAL UNSET INTEGER NELS,VAL(NELS),IEL,NINIT PARAMETER(NINIT=100) REAL*8 INIT(NINIT) IF(NELS.GT.NINIT)THEN PRINT*,'***SETKEYI: No. of elements greater than',NINIT RETURN ENDIF DO 10 IEL=1,NELS 10 INIT(IEL)=VAL(IEL) CALL SETKEY(NAME,1,INIT,NELS,UNSET) END SUBROUTINE SETKEYR(NAME,VAL,NELS,UNSET) * ================================ IMPLICIT UNDEFINED (A-Z) CHARACTER*(*)NAME LOGICAL UNSET INTEGER NELS,IEL,NINIT REAL*4 VAL(NELS) PARAMETER(NINIT=100) REAL*8 INIT(NINIT) IF(NELS.GT.NINIT)THEN PRINT*,'***SETKEYI: No. of elements greater than',NINIT RETURN ENDIF DO 10 IEL=1,NELS 10 INIT(IEL)=VAL(IEL) CALL SETKEY(NAME,1,INIT,NELS,UNSET) END SUBROUTINE SETKEYD(NAME,VAL,NELS,UNSET) * ================================ IMPLICIT UNDEFINED (A-Z) CHARACTER*(*)NAME LOGICAL UNSET INTEGER NELS,I REAL*8 VAL(NELS) CALL SETKEY(NAME,1,VAL,NELS,UNSET) END SUBROUTINE SETKEYS(NAME,VAL,NELS,UNSET) * =========================================== * Interface to SETKEYC using passed string length IMPLICIT UNDEFINED (A-Z) CHARACTER*(*)NAME,VAL(NELS) LOGICAL UNSET INTEGER NELS CALL SETKEYC(NAME,VAL,LEN(VAL(1)),NELS,UNSET) END SUBROUTINE SETKEYC(NAME,VAL,NCHR,NELS,UNSET) * =========================================== IMPLICIT UNDEFINED (A-Z) CHARACTER*(*)NAME LOGICAL UNSET INTEGER NELS,I,NINIT,NCHR,NWD CHARACTER*(*) VAL(NELS) PARAMETER(NINIT=500) REAL*8 INIT(NINIT) NWD=(NCHR+7)/8 IF(NWD*NELS.GT.NINIT)THEN PRINT*,'***SETKEYC: No. of elements greater than',NINIT RETURN ENDIF DO 10 I=1,NELS CALL CNTOR8(VAL(I),INIT(I*NWD-NWD+1),NCHR) 10 CONTINUE CALL SETKEY(NAME,NWD,INIT,NELS,UNSET) END SUBROUTINE SETKEYL(NAME,VAL,NELS,UNSET) * ================================ IMPLICIT UNDEFINED (A-Z) CHARACTER*(*)NAME LOGICAL UNSET INTEGER NELS,I,NINIT LOGICAL VAL(NELS) PARAMETER(NINIT=100) REAL*8 INIT(NINIT),C8TOR8 CHARACTER*8 YES,NO PARAMETER(YES='Y',NO='N') DO 10 I=1,NELS IF(VAL(I))THEN INIT(I)=C8TOR8(YES) ELSE INIT(I)=C8TOR8(NO) ENDIF 10 CONTINUE CALL SETKEY(NAME,1,INIT,NELS,UNSET) END SUBROUTINE KEYRD(NAME,NPER,DAT,NELS) * ===================================== * Reads from KEYIN data. IMPLICIT UNDEFINED (A-Z) INCLUDE "keydefs.inc" CHARACTER*(*)NAME REAL*8 DAT(*) INTEGER IEL,NELS,IPAR,J,NPER CHARACTER*8 CTEMP CTEMP=NAME DO 15 IPAR=1,NPARS IF(PARS(IPAR).EQ.CTEMP)THEN DO 20 IEL=1,NELS DO 20 J=1,NPER 20 DAT(IEL*NPER-NPER+J)=VALS(IPAR-1+IEL*NPER-NPER+J) GOTO 10 ENDIF 15 CONTINUE PRINT*,NAME,' not found' RETURN 10 CONTINUE IF(PARS(IPAR+NPER*NELS-NPER).NE.CTEMP)PRINT*,'Tried to read more ', :'parameters than available for ',NAME END SUBROUTINE KEYRDI(NAME,DAT,NELS) * ================================ IMPLICIT UNDEFINED (A-Z) CHARACTER*(*)NAME INTEGER NELS,I,NINIT INTEGER DAT(NELS) PARAMETER(NINIT=100) REAL*8 INIT(NINIT) CALL KEYRD(NAME,1,INIT,NELS) DO 10 I=1,NELS 10 DAT(I)=INIT(I) END SUBROUTINE KEYRDR(NAME,DAT,NELS) * ================================ IMPLICIT UNDEFINED (A-Z) CHARACTER*(*)NAME INTEGER NELS,I,NINIT REAL*4 DAT(NELS) PARAMETER(NINIT=100) REAL*8 INIT(NINIT) CALL KEYRD(NAME,1,INIT,NELS) DO 10 I=1,NELS 10 DAT(I)=INIT(I) END SUBROUTINE KEYRDD(NAME,DAT,NELS) * ================================ IMPLICIT UNDEFINED (A-Z) CHARACTER*(*)NAME INTEGER NELS,I,NINIT REAL*8 DAT(NELS) CALL KEYRD(NAME,1,DAT,NELS) END SUBROUTINE KEYRDS(NAME,DAT,NELS) * ================================ * Interface to KEYRDC using passed string length CHARACTER*(*)NAME INTEGER NELS CHARACTER*(*) DAT(NELS) CALL KEYRDC(NAME,DAT,LEN(DAT(1)),NELS) END SUBROUTINE KEYRDC(NAME,DAT,NCHR,NELS) * ===================================== IMPLICIT UNDEFINED (A-Z) CHARACTER*(*)NAME INTEGER NELS,IEL,J,NINIT,NCHR,NWD CHARACTER*(*) DAT(NELS) CHARACTER*120 TEXT PARAMETER(NINIT=500) REAL*8 INIT(NINIT) NWD=(NCHR+7)/8 CALL KEYRD(NAME,NWD,INIT,NELS) DO 10 IEL=1,NELS TEXT=' ' WRITE(TEXT,'(15A8)')(INIT(IEL*NWD-NWD+J),J=1,NWD) DAT(IEL)=TEXT 10 CONTINUE END SUBROUTINE KEYRDL(NAME,DAT,NELS) * ================================ IMPLICIT UNDEFINED (A-Z) CHARACTER*(*)NAME INTEGER NELS,IEL,NINIT,NDUMMY LOGICAL DAT(NELS) PARAMETER(NINIT=100) REAL*8 INIT(NINIT) CHARACTER FCH*1,R8TOC8*8 CALL KEYRD(NAME,1,INIT,NELS) DO 10 IEL=1,NELS FCH=R8TOC8(INIT(IEL)) IF(FCH.EQ.'N'.OR.FCH.EQ.'n'.OR.FCH.EQ.'F'.OR.FCH.EQ.'f')THEN DAT(IEL)=.FALSE. ELSE IF(FCH.EQ.'Y'.OR.FCH.EQ.'y'.OR.FCH.EQ.'T'.OR.FCH.EQ.'t') : THEN DAT(IEL)=.TRUE. ELSE PRINT*,'**Logical assignment ',NAME,'= "',FCH, : '" not understood - default value (',DAT(IEL),') assumed.' ENDIF 10 CONTINUE END FUNCTION R8TOC8(R8) * =================== IMPLICIT UNDEFINED (A-Z) REAL*8 R8 CHARACTER*8 R8TOC8 WRITE(R8TOC8,'(A8)')R8 END FUNCTION C8TOR8(C8) * =================== IMPLICIT UNDEFINED (A-Z) REAL*8 C8TOR8 CHARACTER*8 C8 READ(C8,'(A8)')C8TOR8 END SUBROUTINE CNTOR8(IN,OUT,NLETS) * =============================== * * Copies characters into array of REAL*8, without violating any FORTRAN * standards. IMPLICIT UNDEFINED (A-Z) INTEGER NLETS,I,L,W CHARACTER*1 IN(NLETS) REAL*8 OUT(*),C8TOR8 CHARACTER*8 C8 L=0 W=0 C8=' ' DO 10 I=1,NLETS L=L+1 C8(L:L)=IN(I) IF(L.EQ.8)THEN W=W+1 OUT(W)=C8TOR8(C8) C8=' ' L=0 ENDIF 10 CONTINUE IF(L.NE.0)THEN W=W+1 OUT(W)=C8TOR8(C8) ENDIF END INTEGER FUNCTION LEN1(S) C----------------------------------------------------------------------- C LEN1: find the length of a character string excluding trailing blanks. C A blank string returns a value of 0. C C Version 3.0: 1984 Jan 16 - T.J. Pearson, VAX-11 Fortran. C C Subroutines required: C None C C Fortran 77 extensions: C None C----------------------------------------------------------------------- C IMPLICIT UNDEFINED (A-Z) INTEGER I CHARACTER*(*) S C----------------------------------------------------------------------- IF (S.EQ.' ') THEN LEN1 = 1 ELSE DO 10 I=LEN(S),1,-1 LEN1 = I IF (S(I:I).NE.' ') GOTO 20 10 CONTINUE LEN1 = 1 20 CONTINUE END IF END