* PACKAGE USUBF !" 雑(SUBFUNC) * *" [HIS] 90/08/31(numaguti) * ************************************************************************ SUBROUTINE RSET0 !" 値のセット O ( RX , I N , JX , RR ) * * [OUTPUT] REAL RX ( * ) !" データ * * [INPUT] INTEGER N !" セット長さ INTEGER JX !" セット間隔 REAL RR !" セットするスカラー * * [INTERNAL WORK] INTEGER J, KX * KX = 1 DO 1100 J = 1, N RX( KX ) = RR KX = KX + JX 1100 CONTINUE * RETURN END ************************************************************************ SUBROUTINE CLADJ !" 文字列の左よせ M ( HCHR ) * * [MODIFY] CHARACTER HCHR *(*) !" 文字列 * * [INTERNAL WORK] INTEGER LC1, LC2, I * * [EXTERNAL FUNC] INTEGER LENB * LC1 = LEN ( HCHR ) LC2 = LENB ( HCHR ) * IF ( LC2 .NE. 0 ) THEN DO 1100 I = 1, LC1, 1 IF ( I .LE. LC1-LC2 ) THEN HCHR(I:I) = HCHR(I+LC2:I+LC2) ELSE HCHR(I:I) = ' ' END IF 1100 CONTINUE END IF * RETURN END ************************************************************************ INTEGER FUNCTION LENB !" 先行するブランクの数 I ( HC ) * * [INPUT] CHARACTER HC *(*) !" 文字列 * * [INTERNAL WORK] CHARACTER HN *1, HS *1 INTEGER NN, N * HN = CHAR(0) HS = ' ' NN = LEN( HC ) - 1 * DO 1100 N = 1, LEN( HC )-1 IF ( ( HC(N:N) .NE. HN ) .AND. ( HC(N:N) .NE. HS ) ) THEN NN = N-1 GOTO 1200 ENDIF 1100 CONTINUE * 1200 CONTINUE LENB = NN * END ************************************************************************ INTEGER FUNCTION LENC !" 後続するブランクを除いた文字数 I ( HC ) * * [INPUT] CHARACTER HC *(*) !" 文字列 * * [INTERNAL WORK] CHARACTER HN *1, HS *1 INTEGER NN, N * HN = CHAR(0) HS = ' ' NN = 1 * DO 1100 N = LEN( HC ), 2, -1 IF ( ( HC(N:N) .NE. HN ) .AND. ( HC(N:N) .NE. HS ) ) THEN NN = N GO TO 1200 ENDIF 1100 CONTINUE * 1200 CONTINUE LENC = NN * RETURN END ************************************************************************ SUBROUTINE MSGDMP !" メッセージ I ( HLEV , HSUB , HMSG ) * * [INPUT] CHARACTER HLEV *(*) !" メッセージレベル CHARACTER HSUB *(*) !" ルーチン名 CHARACTER HMSG *(*) !" メッセージ * * [INTERNAL SAVE] INTEGER NMMAX, NMSG DATA NMMAX / 100 / DATA NMSG / 0 / SAVE * * [INTERNAL WORK] CHARACTER HSUBX *6 INTEGER LMSG * * [EXTERNAL FUNC] INTEGER LENC * HSUBX = HSUB LMSG = LENC( HMSG ) * IF ( HLEV(1:1).EQ.'E' ) THEN WRITE ( 6,* ) '***** ERROR ('//HSUBX//') *** ' WRITE ( 6,* ) HMSG(1:LMSG) CALL ERRTRA STOP * ELSE IF ( HLEV(1:1) .EQ. 'W' ) THEN NMSG = NMSG+1 IF ( NMSG .LT. NMMAX ) THEN WRITE ( 6,* ) '***** WARNING ('//HSUBX//') *** ' WRITE ( 6,* ) HMSG(1:LMSG) ENDIF ELSE IF ( HLEV(1:1) .EQ. 'M' ) THEN NMSG = NMSG+1 IF ( NMSG .LT. NMMAX ) THEN WRITE ( 6,* ) '***** MESSAGE ('//HSUBX//') *** ' WRITE ( 6,* ) HMSG(1:LMSG) ENDIF END IF IF ( NMSG .EQ. NMMAX ) THEN WRITE ( 6,* ) '+++ THE FOLLOWING MESSAGES ARE SUPRRESSED.' END IF * RETURN END *----------------------------------------------------------------------- *" FMTLIB V03L00 : 90/03/22 *----------------------------------------------------------------------- *" CHVAL *----------------------------------------------------------------------- SUBROUTINE CHVAL(CFMT,VAL,CVAL) *- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - * *" THIS ROUTINE RETURNS CHARACTERIZED VALUE "CVAL" OF "VAL" USING *" USER SPECIFIED FORMAT "CFMT". IF ONE OF THE FOLLOWING OPTINONS IS *" SPECIFIED AS "CFMT", FORMAT WILL BE GENERATED AUTOMATICALLY TO *" REPRESENT 3 SIGNIFICANT DIGITS. * *" CFMT (C*(*)) : FORMAT OR OPTION NAME (I/ ). *" : FORMAT SHOULD BEGIN WITH '('. *" : ONE OF THE FOLLOWING OPTIONS CAN BE SPECIFIED. *" : 'A' - FORMAT IS SET AUTOMATICALLY. *" : 'B' - 'A' AND TRAILING ZERO AND DECIMAL POINT ARE *" : DELETED. *" : 'C' - 'B' AND ZERO BEFORE DECIMAL POINT AND '+' *" : ARE DELETED. *" : 'D' - 'C' BUT ONLY FOR THE EXPONENT TYPE. *" VAL (R) : NUMERIC VALUE SHOULD BE CHARACTERIZED (I/ ). *" CVAL (C*(*)) : CHARACTERIZED VALUE OF "VAL" ( /O). *" : LEN(CVAL) SHOULD BE 8 OR MORE. * *" *** NOT USING INDXCF *** * *- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - * [INPUT] CHARACTER CFMT*(*) REAL VAL * * [OUTPUT] CHARACTER CVAL*(*) * * [INTERNAL WORK] CHARACTER CFMTX*16,CHX*16,CF*1 INTEGER IE, NZ, NC, IDE, IDP, MC REAL RB, VALX LOGICAL LFRST * * [EXTERNAL FUNC] INTEGER LENC SAVE DATA LFRST/.TRUE./ *" / CHECK LENGTH OF OUTPUT CHARACTER / IF (LEN(CVAL).LT.8 .AND. LFRST) THEN CALL MSGDMP('W','CHVAL ','LENGTH OF CHARACTER IS LESS THAN 8.') LFRST=.FALSE. END IF *" / SET FORMAT / CF=CFMT(1:1) IF (CF.NE.'(') THEN *" / AUTOMATIC GENERATION (NOT USER FORMAT) / *" / PICK UP 3 SIGNIFICANT DIGITS AND EXPONENT / CFMTX='(1P,E9.2E2)' WRITE(CHX,CFMTX) VAL READ(CHX(7:9),'(I3)') IE READ(CHX(1:5),'(F5.2)') RB VALX=RB*10.0**IE *" / FORMAT / IF (0.LE.IE .AND. IE.LE.2) THEN *" / DECIMAL / CFMTX='(F6. )' WRITE(CFMTX(5:5),'(I1)') 2-IE ELSE IF (3.LE.IE .AND. IE.LE.4) THEN *" / INTEGER / CFMTX='(I6)' ELSE IF (-3.LE.IE .AND. IE.LE.-1) THEN *" / DECIMAL OR EXPONENT / *" / COUNT TRAILING ZERO / NZ=0 10 IF (.NOT.(CHX(5-NZ:5-NZ).EQ.'0')) GO TO 15 NZ=NZ+1 GO TO 10 15 CONTINUE *" / IF -IE .LE. TRAILING ZERO +1 THEN DECIMAL ELSE EXPONENT / IF (-IE.LE.NZ) THEN CFMTX='(F6.2)' ELSE IF (-IE.LE.NZ+1) THEN CFMTX='(F6.3)' ELSE CFMTX='(1P,E8.2E1)' END IF ELSE IF (-9.LE.IE .AND. IE.LE.9) THEN *" / EXPONENT ( SIGNIFICANT DIGITS = 3 ) / CFMTX='(1P,E8.2E1)' ELSE *" / EXPONENT ( SIGNIFICANT DIGITS = 2 ) / CFMTX='(1P,E8.1E2)' END IF ELSE *" / USER FORMAT / CFMTX=CFMT VALX=VAL END IF *" / ENCODING / CHX=' ' IF (CFMTX(2:2).EQ.'I') THEN WRITE(CHX,CFMTX) NINT(VALX) ELSE WRITE(CHX,CFMTX) VALX END IF *" / LEFT ADJUST / CALL CLADJ(CHX) NC=LENC(CHX) IF (CHX(1:1).EQ.'+') THEN CVAL(1:NC-1)=CHX(2:NC) NC=NC-1 CHX=CVAL(1:NC) END IF *" / OPTION / IF (((CF.EQ.'B' .OR. CF.EQ.'C') .AND. INDEX(CHX,'.').NE.0) + .OR. (CF.EQ.'D' .AND. INDEX(CHX,'E').NE.0)) THEN *" / DELETE TRAILING ZERO AND DECIMAL POINT / *" / CHECK EXPONENT OR DECIMAL / IDE=INDEX(CHX,'E') IF (IDE.EQ.0) THEN *" / DECIMAL / MC=NC ELSE *" / EXPONENT / MC=IDE-1 END IF *" / COUNT TRAILING ZERO / 25 IF (.NOT.(CHX(MC:MC).EQ.'0')) GO TO 20 MC=MC-1 GO TO 25 20 CONTINUE *" / CHECK DECIMAL POINT / IF (CHX(MC:MC).EQ.'.') THEN MC=MC-1 END IF *" / AVAILABLE LENGTH / IF (IDE.EQ.0) THEN NC=MC ELSE CVAL=CHX(1:MC)//CHX(IDE:NC) NC=MC+NC-IDE+1 CHX(1:NC)=CVAL(1:NC) END IF *" / 'C' & 'D' OPTION / IF ((CF.EQ.'C' .OR. CF.EQ.'D') .AND. NC.GT.1) THEN *" / DELETE ZERO BEFORE DECIMAL POINT / IF (CHX(1:1).EQ.'0') THEN CVAL=CHX(2:NC) NC=NC-1 CHX(1:NC)=CVAL(1:NC) ELSE IF (CHX(1:1).EQ.'-' .AND. CHX(2:2).EQ.'0') THEN CVAL=CHX(1:1)//CHX(3:NC) NC=NC-1 CHX(1:NC)=CVAL(1:NC) END IF *" / DELETE '+' IN EXPONENT PART / IDP=INDEX(CHX,'+') IF (IDP.NE.0) THEN CVAL(1:NC-1)=CHX(1:IDP-1)//CHX(IDP+1:NC) NC=NC-1 CHX(1:NC)=CVAL(1:NC) END IF END IF END IF *" / RETURN CHARACTER / CVAL=CHX(1:NC) C CALL CLOWER(CVAL) END