* PACKAGE USUBF     !"  雑(SUBFUNC)
*
*"  [HIS] 90/08/31(numaguti)
*"        98/05/08(ishiwatari) real -> real * 4
*
************************************************************************
      SUBROUTINE RSET0   !" 値のセット  現在使われていない?
     O         ( RX    ,
     I           N     , JX    , RR    )
*
*   [OUTPUT] 
      REAL * 4     RX ( * )                     !" データ
*
*   [INPUT] 
      INTEGER   N                            !" セット長さ
      INTEGER   JX                           !" セット間隔
      REAL * 4    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 * 4   VAL
*
*   [OUTPUT] 
      CHARACTER  CVAL*(*)
*
*   [INTERNAL WORK]       
      CHARACTER  CFMTX*16,CHX*16,CF*1
      INTEGER    IE, NZ, NC, IDE, IDP, MC
      REAL * 4   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
