! $Id$ ! ! *************************************************************** ! ! Check negative value ! ! *************************************************************** ! SUBROUTINE CHKNEG(XL, NRL, STR, XLNEG) IMPLICIT NONE INTEGER, INTENT(IN) :: NRL REAL(8), INTENT(IN) :: XLNEG REAL(8), DIMENSION(0:NRL), INTENT(INOUT) :: XL CHARACTER(*), INTENT(IN) :: STR INTEGER :: NSTRLEN, I, NSTR, NSTR1 CHARACTER(10) :: STR1 DO I = 0, NRL IF (XL(I) .LT. 0.D0) THEN NSTR1 = 0 CALL APITOS(STR1, NSTR1, I) NSTR = NSTRLEN(STR) WRITE(6,*) '### ERROR(CHKNEG) : ', STR(2:NSTR+1), & '(', STR1(1:NSTR1), ') is', SNGL(XL(I)) XL(I) = XLNEG END IF END DO RETURN END ! ! *************************************************************** ! ! For no '*** MATH LIBRARY ERROR 14: DEXP(X) UNDERFLOW' ! ! *************************************************************** ! REAL(8) FUNCTION EXPV(X) IMPLICIT NONE REAL(8), INTENT(IN) :: X IF (X .LT. -708) THEN EXPV = 0.D0 ELSE EXPV = EXP(X) END IF RETURN END ! ! *************************************************************** ! ! Length of strings STR(2:NSTRLEN(A)+1) ! ! *************************************************************** ! REAL(8) FUNCTION NSTRLEN(STR) IMPLICIT NONE CHARACTER(*), INTENT(IN) :: STR INTEGER :: I CHARACTER(1) :: DELIM DELIM = STR(1:1) DO I = 2, LEN(STR) IF (STR(I:I) .EQ. DELIM) THEN NSTRLEN = I - 2 GOTO 10 END IF END DO NSTRLEN = LEN(STR) 10 CONTINUE RETURN END ! ! *************************************************************** ! ! SUBROUTINE APpend Integer TO Strings ! INPUT : NSTR, I ! NSTR : Number of STR. First, NSTR = 0. ! OUTPUT : STR, NSTR ! STR(NSTR(original)+1:NSTR(return)) ! ! *************************************************************** ! SUBROUTINE APITOS(STR, NSTR, I) IMPLICIT NONE INTEGER, INTENT(IN) :: I INTEGER, INTENT(INOUT) :: NSTR CHARACTER(*), INTENT(OUT) :: STR INTEGER :: J, NSTRI CHARACTER(25) :: KVALUE WRITE(KVALUE,'(I25)') I J = 0 10 CONTINUE J = J + 1 IF (KVALUE(J:J) .EQ. ' ') GOTO 10 NSTRI = 25 - J + 1 STR(NSTR+1:NSTR+NSTRI) = KVALUE(J:25) NSTR = NSTR + NSTRI RETURN END ! ! *************************************************************** ! ! SUBROUTINE APpend Textx TO Strings ! INPUT : NSTR, TX ! NSTR : Number of STR. First, NSTR = 0. ! TX : Delimited text ! OUTPUT : STR, NSTR ! STR(NSTR(original+1):NSTR(return)) ! ! *************************************************************** ! SUBROUTINE APTTOS(STR, NSTR, TX) IMPLICIT NONE INTEGER, INTENT(INOUT) :: NSTR CHARACTER(*), INTENT(IN) :: TX CHARACTER(*), INTENT(OUT) :: STR INTEGER :: NTX, NSTRLEN NTX = NSTRLEN(TX) STR(NSTR+1:NSTR+NTX) = TX(2:NTX+1) NSTR = NSTR + NTX RETURN END ! ! *************************************************************** ! ! SUBROUTINE APpend Strings TO Strings ! INPUT : NSTR, INSTR, NINSTR ! NSTR : Number of STR. First, NSTR = 0. ! NINSTR : Number of INSTR ! OUTPUT : STR, NSTR ! STR(NSTR(original+1):NSTR(return)) ! ! *************************************************************** ! SUBROUTINE APSTOS(STR, NSTR, INSTR, NINSTR) IMPLICIT NONE INTEGER, INTENT(IN) :: NINSTR CHARACTER(*), INTENT(IN) :: INSTR INTEGER, INTENT(INOUT) :: NSTR CHARACTER(*), INTENT(OUT) :: STR STR(NSTR+1:NSTR+NINSTR) = INSTR(1:NINSTR) NSTR = NSTR + NINSTR RETURN END ! ! *************************************************************** ! ! SUBROUTINE APpend Double precision real number TO Strings ! INPUT : NSTR, D, FORM ! NSTR : Number of STR. First, NSTR = 0. ! FORM : '{D|E|F|G}n' or '*' ! OUTPUT : STR, NSTR ! STR(NSTR(original+1):NSTR(return)) ! ! *************************************************************** ! SUBROUTINE APDTOS(STR, NSTR, D, FORM) IMPLICIT NONE REAL(8), INTENT(IN) :: D CHARACTER(*), INTENT(IN) :: FORM INTEGER, INTENT(INOUT) :: NSTR CHARACTER(*), INTENT(OUT) :: STR INTEGER(1) :: IND INTEGER :: L, IS, IE, NSTRD CHARACTER(10) :: KFORM, KVALUE*25 L = LEN(FORM) IF (L .EQ. 0) THEN GOTO 30 ELSE IF (L .EQ. 1) THEN IF (FORM(1:1) .EQ. '*') THEN WRITE(KVALUE,*) SNGL(D) ELSE GOTO 30 END IF ELSE READ(FORM(2:2),'(I1)',ERR=30) IND IF (FORM(1:1) .EQ. 'F') THEN WRITE(KFORM,'(A,I2,A)') '(F25.', IND, ')' WRITE(KVALUE,KFORM) D ELSE IF (FORM(1:1).EQ.'D' .OR. FORM(1:1).EQ.'E' & .OR. FORM(1:1).EQ.'G') THEN WRITE(KFORM,'(3A,I2,A)') '(1P', FORM(1:1), '25.', IND, ')' WRITE(KVALUE,KFORM) D ELSE GOTO 30 END IF ENDIF IS = 0 10 CONTINUE IS = IS + 1 IF (KVALUE(IS:IS) .EQ. ' ') GOTO 10 IE = IS 20 CONTINUE IE = IE + 1 IF (KVALUE(IE:IE).NE.' ' .AND. IE.LT.25) GOTO 20 IF (KVALUE(IE:IE).NE.' ' .AND. IE.EQ.25) IE = 25 + 1 IF (KVALUE(IS:IS) .EQ. '-') THEN IF (IS.GT.1 .AND. KVALUE(IS+1:IS+1).EQ.'.') THEN KVALUE(IS-1:IS-1) = '-' KVALUE(IS :IS ) = '0' IS = IS - 1 END IF ELSE IF (KVALUE(IS:IS) .EQ. '.') THEN IF (IS .GT. 1) THEN KVALUE(IS-1:IS-1) = '0' IS = IS - 1 END IF END IF NSTRD = IE - IS STR(NSTR+1:NSTR+NSTRD) = KVALUE(IS:IE-1) NSTR = NSTR + NSTRD RETURN 30 CONTINUE WRITE(6,*) '### ERROR(APDTOS) : Invalid Format : "', FORM , '"' NSTRD = 0 RETURN END ! ! *************************************************************** ! ! SUBROUTINE APpend Real number TO Strings ! INPUT : NSTR, GR, FORM ! NSTR : Number of STR. First, NSTR = 0. ! FORM : '{D|E|F|G}n' or '*' ! OUTPUT : STR, NSTR ! STR(NSTR(original+1):NSTR(return)) ! ! *************************************************************** ! SUBROUTINE APRTOS(STR, NSTR, GR, FORM) IMPLICIT NONE REAL, INTENT(IN) :: GR CHARACTER(*), INTENT(IN) :: FORM INTEGER, INTENT(INOUT) :: NSTR CHARACTER(*), INTENT(OUT) :: STR REAL(8) :: D D = DBLE(GR) CALL APDTOS(STR, NSTR, D, FORM) RETURN END ! ! *************************************************************** ! ! Convert Strings to Upper Case ! ! *************************************************************** ! SUBROUTINE TOUPPER(KTEXT) IMPLICIT NONE CHARACTER(*), INTENT(IN) :: KTEXT INTEGER :: NCHAR, I, ID REAL(8), DIMENSION(256) :: IASC NCHAR = LEN(KTEXT) CALL CHRASC(KTEXT, IASC, NCHAR) DO I = 1, NCHAR ID = IASC(I) IF(ID .GE. 97 .AND. ID .LE. 122) IASC(I) = ID - 32 END DO CALL ASCCHR(IASC, KTEXT, NCHAR) RETURN END