!     Last change:  TEC  17 Mar 2000    4:18 pm
      PROGRAM DOS_Calibration
!
!     Calibration program for...
!     ...Program to calculate basin runoff.
!        by Thomas E. Croley II, 29feb00
!
!     This program is a DOS program to enable use of the LBRM under DOS.
!     Set "cCcons" to "1" to run the model in a calibration mode (allows
!     the internal recomputation of "Cons").
!
!     Compile and link as follows (Lahey Fortran 95 used here):
!
!     lf95 ErrorProcessDOS.f95 -c
!     lf95 GLERLutil.f95       -c
!     lf95 LBRM.f95            -c
!     lf95 DOScalib.f95        -c
!     lf95 DOScalib.obj LBRM.obj GLERLutil.obj ErrorProcessDOS -out CALIBRATE.EXE
!
!     See LBRM.F95 file for documentation on all files except the FLOW DATA
!     FILE (named as "DATAFILE" in LBRM.CFG) which is described here:
!
!     FLOW DATA FILE  (could be named anything)
!        This file contains the daily flow data with which to match LBRM output
!        in a calibration.
!
!        The format is as follows:
!
!        1st record: Identifier (FORMAT: A)
!                    |        |
!                    |________|___This is an arbitrary identification string
!                                 that is skipped by this program.
!
!        2nd record: Identifier (FORMAT: A)
!                    |        |
!                    |________|___This is a header string indentifying the columns
!                                 that is skipped by this program.
!
!        Records 3 through the end of the file have the daily flow amounts.
!
!           dd mm yyyy Run (FORMAT: 2I2, I4, 6E11.4E2)
!           || || |  | | |
!           || || |  | |_|_____runoff volume for this day (cm)
!           || || |__|_________four-digit year of data's date
!           || ||______________two-digit month of data's date
!           ||_________________two-digit day of data's date
!
!
      USE LBRM_Main

      IMPLICIT NONE
      INTEGER :: iFGFG, iRtn, iCnt, iRptFg, iUpDn, iOptFg, I, iD, iM, iY, Seq
      INTEGER :: iFIi, iRelCng, iParmm, IOS
      REAL    :: cCcons
      REAL    :: Q, F, Xrcc, AvgFM, VarM, Avg, Var, Prod, RMSE, FI, Corr
      REAL    :: LTnsg, LTrun, LTint, LTgwf, LTuev, LTlev
      REAL    :: AvgSS, AvgUSZ, AvgLSZ, AvgGZ
      LOGICAL OptimizeRMSE
!
!     This will be dimensioned to the number of days in the 
!     simulation (iNoDataPoints)
!
      REAL, DIMENSION(:), ALLOCATABLE :: FlowData

      OptimizeRMSE = .TRUE. ! "true" to optimize RMSE, "false" for Corr
      CALL ClearFilesOpen()
!
!     Read information from the LBRM.CFG file.
!
      CALL ReadLBRMCFGfile
      IF(ErrorLevel .NE. 0) GOTO 899
      IF (DataFile .EQ. '---') THEN
         ErrorMessage = 'CALIB: No DATAFILE entry in LBRM.CFG!'
         GOTO 899
      END IF
!
!     Find array sizes and allocate RAM for the simulation
!
      CALL AllocateFromDOS
      IF (ErrorLevel .NE. 0) GOTO 899
      ALLOCATE(FlowData(iNoDataPoints), STAT=IOS)
      IF (IOS .NE. 0) THEN
         ErrorMessage = 'Error allocating FlowData array.'
         GOTO 899
      END IF
!
!     Read values from the parameter file.
!
      CALL ReadParameterFile
      IF(ErrorLevel .NE. 0) GOTO 899
      IF (iFDCR .LT. iFDMR .OR. iFDCR .GT. iLDMR) THEN
         ErrorMessage = 'Calibration period not within simulation period'
         GOTO 899
      END IF
      IF (iNoChng .LT. 1 .OR. iNoChng .GT. 3) THEN
         ErrorMessage = 'Changes limited to from one to THREE digits only'
         GOTO 899
      END IF
      IF (iParm .LT. 1 .OR. iParm .GT. 9) THEN
         ErrorMessage = 'Changes allowed only in parameters 1 to 9'
         GOTO 899
      END IF
      DO I = 1, 9
         IF (Ixrc(I) .GT. iNoChng) Ixrc(I) = iNoChng
         IF (Ixrc(I) .NE. 0) THEN
            IF (Parameter(I) .LT. .1E-9) Parameter(I) = .1E-9
            CALL Round(Parameter(i), Ixrc(i))
         END IF
      END DO
!
!     Read values from the boundary conditions file.
!
      CALL ReadBoundaryConditionsFile(iBCD, Upper, Lower, Ground, Surface, Snow)
      IF(ErrorLevel .NE. 0) GOTO 899
!
!     Read all of the meteorological data.
!
      CALL ReadLBRMDataFile(Tmx, Tmn, Prc)
      IF(ErrorLevel .NE. 0) GOTO 899
!
!     Read the actual flow data (assumed units are cm over the basin area).
!
      DO I = iFDCR, iLDMR
         FlowData(I - iFDCR + 1) = -999.
      END DO
      ErrorMessage = 'CALIB: Error opening file '//TRIM(DATAFILE)//'!'
      OPEN(UNIT=31, FILE=TRIM(DATAFILE), STATUS='OLD', ERR=899)
      CALL FileWasOpened(31)
      ErrorMessage = 'CALIB: Error reading file '//TRIM(DATAFILE)//'!'
      READ(31, *, ERR=899)
      READ(31, *, ERR=899)
      READ(31, 3103, IOSTAT=IOS) iD, iM, iY, Q
      DO WHILE (IOS .EQ. 0)
         CALL DateSequence(iD, iM, iY, Seq); IF (ErrorLevel .NE. 0) GOTO 899
         IF (Seq .GE. iFDCR .AND. Seq .LE. iLDMR)                         &
     &      FlowData(Seq - iFDCR + 1) = Q * Area / 100.  ! convert to cubic meters
         READ(31, 3103, IOSTAT=IOS) iD, iM, iY, Q
      END DO
      CLOSE(31)
      CALL FileWasClosed(31)
      IF (IOS .GT. 0) GOTO 899   ! file read error
!
!     Compute actual flow statistics.
!
      Avg = 0.
      Var = 0.
      iFIi = 0
      DO I = iFDCR, iLDMR
         F = FlowData(I - iFDCR + 1)
         IF (F .GE. 0) THEN
            Avg = Avg + F
            Var = Var + F * F
            iFIi = iFIi + 1
         END IF
      END DO
      FI = FLOAT(iFIi)
      Avg = Avg / FI
      Var = Var / FI
      Var = Var - Avg ** 2
      Avg = Avg / Area * 100.
      Var = SQRT(Var) / Area * 100.
!
!     Systematic parameter search
!
      iFGFG = 1
      iRtn = 0
      iCnt = 0
      iRptFg = 1
      iUpDn = 1
      iOptFg = -1
!
!     Parameter change loop.
!
      WRITE(6, 1060) TRIM(RunID)
      SvRMSE = 0.            ! so first write to parameter file is zero
      CorrS = 0.             ! so first write to parameter file is zero
      RMSE = 0.              ! so first write to terminal is zero
      Corr = 0.              ! so first write to terminal is zero
      AvgFM = 0.             ! so first write to terminal is zero
      VarM = 0.              ! so first write to terminal is zero
      LTnsg = 1.             ! so first write to terminal is zero
      LTrun = 0.             ! so first write to terminal is zero
      LTint = 0.             ! so first write to terminal is zero
      LTgwf = 0.             ! so first write to terminal is zero
      LTuev = 0.             ! so first write to terminal is zero
      LTlev = 0.             ! so first write to terminal is zero
      AvgSS = 0.             ! so first write to terminal is zero
      AvgUSZ = 0.            ! so first write to terminal is zero
      AvgLSZ = 0.            ! so first write to terminal is zero
      AvgGZ = 0.             ! so first write to terminal is zero
      CALL Wrt(.FALSE., Corr, RMSE, Avg, AvgFM, var, VarM, LTnsg, LTrun,  &
     & LTint, LTgwf, LTuev, LTlev, AvgSS, AvgUSZ, AvgLSZ, AvgGZ)
      SvRMSE = 0.1E+39
      GOTO 26
   20 Xrcc = 10. ** (1 - Ixrc(iParm) + INT(ALOG10(Parameter(iParm) *.99999)))
      IF (Parameter(iParm) .LT. 1.00001) Xrcc = Xrcc / 10.
      IF (INT(Parameter(iParm) / Xrcc * 1.00001) .EQ. 10 ** Ixrc(iParm)   &
     & .AND. iUpDn .EQ. 1) Xrcc = Xrcc * 10.
      Parameter(iParm) = (INT(Parameter(iParm) * 1.00001 / Xrcc) + iUpDn) * Xrcc
      CALL Round(Parameter(iParm), Ixrc(iParm))
      IF(Parameter(iParm) .LT. .99999E-10 .OR. (iParm .NE. 2 .AND.        &
     & Parameter(iParm) .GT. .99999E+9)) GOTO 22
      IF (iRptFg .EQ. 0) GOTO 554
      iRptFg = 0
      IF (iParm .LE. 2) iRptFg = 1
!
!     Find sum of squared errors
!
      IF (iParm .NE. 2 .AND. iParm .NE. 3 .AND. iFGFG .EQ. 0) THEN
      ELSE
         Parameter(10) = 0.  ! force recomputation of "Cons"
      ENDIF
!
!     1st, call LBRM.
!
  554 cCcons = 1  ! will do a "calibration run" instead of a "simulation run"
      CALL LBRM_Engine(cCcons, BC, DS, iBCD, Upper, Lower, Ground,        &
     &                 Surface, Snow, Tmx, TMn, Prc, OutRunoff, OutUszm,  &
     &                 OutLszm, OutGzm, OutSs, OutSnw,                    &
     &                 LTnsg, LTrun, LTint, LTgwf, LTuev, LTlev)
      IF(ErrorLevel .NE. 0) GOTO 899
      Parameter(10) = cCcons
!
!     2nd, read model output and compute statistics.
!
      AvgFM = 0.
      VarM = 0.
      Prod = 0.
      RMSE = 0.
      iFIi = 0
      AvgSS = 0.
      AvgUSZ = 0.
      AvgLSZ = 0.
      AvgGZ = 0.
      DO I = iFDCR, iLDMR
         AvgSS = AvgSS + OutSS(I - iFDMR + 1)
         AvgUSZ = AvgUSZ + OutUszm(I - iFDMR + 1)
         AvgLSZ = AvgLSZ + OutLszm(I - iFDMR + 1)
         AvgGZ = AvgGZ + OutGzm(I - iFDMR + 1)
         F = FlowData(I - iFDCR + 1)       ! actual
         IF (F .GE. 0) THEN
            Q = OutRunoff(I - iFDMR + 1)   ! model
            AvgFM = AvgFM + Q
            VarM = VarM + Q ** 2
            Prod = Prod + F * Q
            RMSE = RMSE + (F - Q) ** 2
            iFIi = iFIi + 1
         END IF
      END DO
      AvgSS = AvgSS / (iLDMR - iFDCR + 1) / Area * 100.
      AvgUSZ = AvgUSZ / (iLDMR - iFDCR + 1) / Area * 100.
      AvgLSZ = AvgLSZ / (iLDMR - iFDCR + 1) / Area * 100.
      AvgGZ = AvgGZ / (iLDMR - iFDCR + 1) / Area * 100.
!      AvgSS = OutSS(iLDMR - iFDCR + 1) / Area * 100.
!      AvgUSZ = OutUszm(iLDMR - iFDCR + 1) / Area * 100.
!      AvgLSZ = OutLszm(iLDMR - iFDCR + 1) / Area * 100.
!      AvgGZ = OutGzm(iLDMR - iFDCR + 1) / Area * 100.
      FI = FLOAT(iFIi)
      AvgFM = AvgFM / FI
      VarM = VarM / FI
      VarM = VarM - AvgFM ** 2
      Prod = Prod / FI / Area * 100. / Area * 100.
      AvgFM = AvgFM / Area * 100.
      VarM = SQRT(VarM) / Area * 100.
      Corr = (Prod - Avg * AvgFM) / Var / VarM
      RMSE = RMSE / FI
      RMSE = SQRT(RMSE) / Area * 100.  ! convert to cm
      !CALL Round(RMSE, 6)   ! limit comparisons to SIX significant digits
      !CALL Round(Corr, 6)   ! limit comparisons to SIX significant digits
      CALL Wrt(.TRUE., Corr, RMSE, Avg, AvgFM, var, VarM, LTnsg, LTrun,   &
     & LTint, LTgwf, LTuev, LTlev, AvgSS, AvgUSZ, AvgLSZ, AvgGZ)
      IF (OptimizeRMSE .AND. RMSE .GE. SvRMSE) GOTO 22
      IF (.NOT. OptimizeRMSE .AND. Corr .LE. CorrS) GOTO 22
      SvRMSE = RMSE
      CorrS = Corr
      iRtn = iRtn + 1
      iOptFg = iOptFg + 1
      CALL WriteParameterFile
      GOTO 20
   22 Parameter(iParm) = (INT(Parameter(iParm) * 1.00001 / Xrcc) - iUpDn) * Xrcc
      CALL Round(Parameter(iParm), Ixrc(iParm))
      CALL WriteParameterFile
      IF(iOptFg .GT. 0) GOTO 23
      iOptFg = 1
      iUpDn = -1
      GOTO 20
   23 iOptFg = 0
      iUpDn = 1
   27 iCnt = iCnt + 1
      IF (iRtn .NE. 0) iCnt = 0
      iRtn = 0
      IF (iCnt .NE. 8) GOTO 24
      iCnt = 100
      iRelCng = 0
      DO I = 1, 9
       IF (Ixrc(I) .LT. iCnt .AND. Ixrc(I) .NE. 0) iCnt = Ixrc(I)
      END DO
      DO 35 I = 1, 9
       IF (Ixrc(I) .EQ. 0) GOTO 38
       IF (Ixrc(I) .EQ. iCnt) Ixrc(I) = Ixrc(I) + 1
       IF (Ixrc(I) .LE. iNoChng) GOTO 35
       Ixrc(I) = iNoChng
   38  iRelCng = iRelCng + 1
   35 CONTINUE
      iCnt = 0
      IF (iRelCng .EQ. 9) GOTO 34
   24 iParm = iParm + 1
      iParmm = iParm
      IF (iParm .GE. 10) iParm = 1
      CALL WriteParameterFile
      iParm = iParmm
   28 IF (iParm .LT. 10) GOTO 26
      iParm = 1
      iRptFg = 1
   26 IF (Parameter(iParm) .GT. .1e+39 .OR. Ixrc(iParm) .EQ. 0) GOTO 27
      GOTO 20
   34 WRITE(6, 1061)
      CALL WriteParameterFile
      Corr = CorrS
      RMSE = SvRMSE
      CALL Wrt(.FALSE., Corr, RMSE, Avg, AvgFM, var, VarM, LTnsg, LTrun,  &
     & LTint, LTgwf, LTuev, LTlev, AvgSS, AvgUSZ, AvgLSZ, AvgGZ)
      CALL LogIt(Corr, RMSE, Avg, AvgFM, var, VarM, LTnsg, LTrun, LTint,  &
     & LTgwf, LTuev, LTlev, AvgSS, AvgUSZ, AvgLSZ, AvgGZ)
      GOTO 898
!
!     Error Handling
!
  899 CALL PassMsg              ! Error Handling: ErrorMessage must have been set.
  898 CALL CloseAllFiles()
      CALL DeallocateFromDOS
      DEALLOCATE(FlowData, STAT=IOS)
 1060 FORMAT(1H+, 'Calibration: ', A)
 3103 FORMAT(2I2, I4, E11.4E2)
 1061 FORMAT(A)
      END PROGRAM DOS_Calibration

      SUBROUTINE Wrt(Identify, Corr, RMSE, Avg, AvgFM, var, VarM, LTnsg,  &
     & LTrun, LTint, LTgwf, LTuev, LTlev, AvgSS, AvgUSZ, AvgLSZ, AvgGZ)
      USE LBRM_Main
      IMPLICIT NONE
      LOGICAL, INTENT(IN) :: Identify
      REAL, INTENT(IN) :: Corr, RMSE, Avg, AvgFM, Var, VarM, LTnsg,       &
     & LTrun, LTint, LTgwf, LTuev, LTlev, AvgSS, AvgUSZ, AvgLSZ, AvgGZ
      INTEGER I
      CHARACTER (LEN=1), DIMENSION(10) :: Ix
      CHARACTER (LEN=23) :: SciNot
      CHARACTER (LEN=34) :: Line
      CHARACTER (LEN=3) :: CorS
      CHARACTER (LEN=5) :: AvgS
      CHARACTER (LEN=4) :: LTrunS, LTintS, LTgwfS, LTuevS, LTlevS

      DO I = 1, 10
         Ix(I) = ' '
      END DO
      IF (Identify) THEN
         Ix(iParm) = '*'
!         Ix(iParm+1) = '*'
      END IF
      WRITE(Line, 555) Corr, AvgFm/Avg, LTrun/LTnsg, LTint/LTnsg,         &
     & LTgwf/LTnsg, LTuev/LTnsg, LTlev/LTnsg
  555 FORMAT(F4.2, 6F5.3)
      READ(Line, 554) CorS, AvgS, LTrunS, LTintS, LTgwfS, LTuevS, LTlevS
  554 FORMAT(1X, A3, A5, 5(1X, A4))
      WRITE(6, 556) Ix(1), SciNot(Parameter(1), 3, 1),                    &
     &              Ix(2), SciNot(Parameter(2), 3, 1),                    &
     &              Ix(3), SciNot(Parameter(3), 3, 1),                    &
     &              Ix(4), SciNot(Parameter(4), 3, 1),                    &
     &              Ix(5), SciNot(Parameter(5), 3, 1),                    &
     &              Ix(6), SciNot(Parameter(6), 3, 1),                    &
     &              Ix(7), SciNot(Parameter(7), 3, 1),                    &
     &              Ix(8), SciNot(Parameter(8), 3, 1),                    &
     &              Ix(9), SciNot(Parameter(9), 3, 1),                    &
     &              Ix(10), CorS,                                         &
     &                     SciNot(RMSE, 6, 1),                            &
     &                     AvgS,                                          &
     &                     LTrunS,                                        &
     &                     LTintS,                                        &
     &                     LTgwfS,                                        &
     &                     LTuevS,                                        &
     &                     LTlevS,                                        &
     &                     SciNot(AvgSS, 3, 1),                           &
     &                     SciNot(AvgUSZ, 3, 1),                          &
     &                     SciNot(AvgLSZ, 3, 1),                          &
     &                     SciNot(AvgGZ, 3, 1)
  556 FORMAT(1X, 9(A, A6), A, A3, ' ', A9, ' ', A5, 5(' ', A4), 4(' ', A6))
      RETURN
      END SUBROUTINE Wrt

      SUBROUTINE LogIt(Corr, RMSE, Avg, AvgFM, var, VarM, LTnsg,  &
     & LTrun, LTint, LTgwf, LTuev, LTlev, AvgSS, AvgUSZ, AvgLSZ, AvgGZ)
      USE LBRM_Main
      IMPLICIT NONE
      REAL, INTENT(IN) :: Corr, RMSE, Avg, AvgFM, Var, VarM, LTnsg,       &
     & LTrun, LTint, LTgwf, LTuev, LTlev, AvgSS, AvgUSZ, AvgLSZ, AvgGZ
      INTEGER I, I1, I2, I3, I4, I5, I6, I7, I8, I9
      CHARACTER (LEN=23) :: SciNot

      OPEN(UNIT = 21, FILE = 'CALIBLOG.TXT', STATUS = 'OLD', IOSTAT = I,  &
     &   CARRIAGECONTROL = 'LIST')
      IF (I .NE. 0) THEN
         CLOSE(21, STATUS = 'DELETE', IOSTAT = I)
         OPEN(UNIT = 21, FILE = 'CALIBLOG.TXT', STATUS = 'NEW',           &
     &      CARRIAGECONTROL = 'LIST')
         WRITE(21, 555)
         CLOSE(21)
         OPEN(UNIT = 21, FILE = 'CALIBLOG.TXT', STATUS = 'OLD',           &
     &      CARRIAGECONTROL = 'LIST', IOSTAT = I)
      END IF
      I1 = -1
      DO WHILE (I .EQ. 0)
         READ(21, *, IOSTAT = I)
         I1 = I1 + 1
      END DO
      CLOSE(21)
      OPEN(UNIT = 21, FILE = 'CALIBLOG.TXT', STATUS = 'OLD',              &
     &   CARRIAGECONTROL = 'LIST')
     DO I = 1, I1
        READ(21, *)
     END DO
      CALL SequenceDate(I1, I2, I3, iFDMR)
      CALL SequenceDate(I4, I5, I6, iFDCR)
      CALL SequenceDate(i7, i8, i9, iLDMR)
      WRITE(21, 556) ParmFile(1:12),                                      &
     &               I1, I2, I3, I4, I5, I6, I7, I8, I9,                  &
     &               SciNot(Area, 6, 2),                                  &
     &               SciNot(Parameter(1), 3, 1),                          &
     &               SciNot(Parameter(2), 3, 1),                          &
     &               SciNot(Parameter(3), 3, 1),                          &
     &               SciNot(Parameter(4), 3, 1),                          &
     &               SciNot(Parameter(5), 3, 1),                          &
     &               SciNot(Parameter(6), 3, 1),                          &
     &               SciNot(Parameter(7), 3, 1),                          &
     &               SciNot(Parameter(8), 3, 1),                          &
     &               SciNot(Parameter(9), 3, 1),                          &
     &               SciNot(Parameter(10), 6, 1),                         &
     &               SciNot(USZC/Area, 3, 1),                             &
     &               SciNot(Corr, 3, 1),                                  &
     &               SciNot(RMSE, 6, 1),                                  &
     &               AvgFM/Avg,                                           &
     &               LTrun/LTnsg,                                         &
     &               LTint/LTnsg,                                         &
     &               LTgwf/LTnsg,                                         &
     &               LTuev/LTnsg,                                         &
     &               LTlev/LTnsg,                                         &
     &               SciNot(AvgSS, 3, 1),                                 &
     &               SciNot(AvgUSZ, 3, 1),                                &
     &               SciNot(AvgLSZ, 3, 1),                                &
     &               SciNot(AvgGZ, 3, 1)
      CLOSE(21)
      RETURN
  555 FORMAT('  Param File  Start Date  Cal Start   Cal Stop       Area  Tbase   Melt' &
     & '   Perc UprEvp Intrfl DpPerc LwrEvp Grdwtr Surfac Heat Cons   US' &
     & 'ZC   Corr       RMSE Ratio SrfRn Intfl GrdFl UprEv LwrEv  AvgSS ' &
     & 'AvgUSZ AvgLSZ  AvgGZ', /, '                                                  ' &
     & '     m2  deg.C  cm/dd    d-1    m-3    d-1    d-1    m-3    d-1 ' &
     & '   d-1   cal/cm2     cm                cm                       ' &
     & '                  cm     cm     cm     cm')
  556 FORMAT(A12, ' ', 3(2I3, I5), ' ', A10, 9(' ', A6), ' ', A9, ' ', A6, ' ', A7, &
     & ' ', A9, 6F6.3, 4(' ', A6))
      END SUBROUTINE LogIt

      CHARACTER*23 FUNCTION SciNot(Xr4, Mi2, Ei2)
!
!     Routine to return string of number in scientific notation.  Differs from
!     standard fortran in that the exponent sign (E) is not printed to save
!     space.  Call with REAL*4 number as Xr4, mantissa field width as
!     Mi2 (1...15), and exponent field width as Ei2 (1...5).  If field widths
!     outside of the ranges are used, the limits default.
!
      IMPLICIT NONE
      INTEGER Mi2, Ei2, J, M, E, K, I
      REAL Xr4
      DOUBLE PRECISION X
      CHARACTER*6 Exponent, Mantissa*16, SIGN*1

      M = MIN(Mi2, 15)
      M = MAX(M, 1)
      E = MIN(Ei2, 5)
      E = MAX(E, 1)
      X = Xr4
      IF (X .LT. 0.0D0) THEN
       X = -X
       SIGN = '-'
      ELSE
       SIGN = ' '
      END IF
      IF (X .EQ. 0.0D0) THEN
       SciNot = '.'
       DO J = 1, M
        SciNot = SciNot(1:J) // '0'
       END DO
       SciNot = SciNot(1:M+1) // '+'
       DO J = 1, E
        SciNot = SciNot(1:M+1+J) // '0'
       END DO
      ELSE
       I = INT(DLOG10(X) + 100001.000001D0) - 100000
       IF (I .EQ. 0) THEN
        J = 1
       ELSE
        J = INT(ALOG10(FLOAT(ABS(I)) + .1)) + 1
       END IF
       IF (I .LT. 0) THEN
        Exponent = '-'
        IF (J .GT. E) THEN
         DO K = 1, E
          Exponent = Exponent(1:K) // '*'
         END DO
        ELSE        
         DO K = 1, E
          Exponent = Exponent(1:K)                                        &
     &     // CHAR((-I - (-I / 10**(E-K+1)) * 10**(E-K+1))/10**(E-K)+48)
         END DO
        END IF
       ELSE
        Exponent = '+'
        IF (J .GT. E) THEN
         DO K = 1, E
          Exponent = Exponent(1:K) // '*'
         END DO
        ELSE
         DO K = 1, E
          Exponent = Exponent(1:K)                                        &
     &     // CHAR((I - (I / 10**(E-K+1)) * 10**(E-K+1))/10**(E-K) + 48)
         END DO
        END IF
       END IF
       X = INT(X * 10. ** (M - I) + 0.5)
       Mantissa = '.'
       DO J = 1, M
        Mantissa = Mantissa(1:J)                                          &
     &   // CHAR(INT((X - INT(X / 10. ** (M - J + 1))                     &
     &   * 10. ** (M - J + 1)) / 10. ** (M - J) + 0.00000000001D0) + 48)
       END DO
       SciNot = Mantissa(1:M+1) // Exponent(1:E+1)
      END IF
      DO J = M + E + 3, 22
       SciNot = SciNot(1:J-1) // CHAR(0)
      END DO
!      SciNot = SIGN // SciNot(1:22)  ! suppress sign or leading blank if numbers are always known to be positive
      RETURN
      END
