MODULE FRWDMDL USE PARAMS USE TRANSMIS USE DATAFILES USE MOLCPARAM USE SOLAR USE SYNSPEC USE CHANNEL USE BANDPARAM USE RETVPARAM USE WRITEOUT USE INITIALIZE IMPLICIT NONE CHARACTER, DIMENSION(NMAX) :: PNAME*14 CHARACTER (LEN=7), DIMENSION(MOLMAX) :: SDV_GAS CHARACTER (LEN=7), DIMENSION(MOLMAX) :: LM_GAS CONTAINS !------------------------------------------------------------------------------ SUBROUTINE FM(XN, YN, KN, NFIT, NVAR, KFLG, ITER, TFLG ) IMPLICIT NONE INTEGER :: NFIT !, M - COLUMNS - 1 SPECTRUM INTEGER :: NVAR !, N - ROWS - FOR EACH FIT PARAMETER INTEGER :: ITER LOGICAL :: KFLG, BUG1 = .FALSE. LOGICAL :: TFLG, IFCOSAVE=.FALSE. REAL(DOUBLE) :: XN(NVAR) REAL(DOUBLE) :: YN(NFIT) REAL(DOUBLE) :: KN(NFIT,NVAR) CHARACTER :: GASFNAME*(IFLNMSZ) CHARACTER :: TITLE*(80) INTEGER :: iii INTEGER :: NVAR1, KFIT, KFIT2, KZERO, KPHASE, JATMOS, IPARM, I, NCOUNT, & KK, K, MXONE, IBAND, N, JSCAN, MONONE, N1, N2, N3, J, MSHIFT, NS, NR, & ns1, ns2 LOGICAL :: XRET, TRET REAL(DOUBLE), DIMENSION(3) :: B REAL(DOUBLE), DIMENSION(NMAX) :: PARM REAL(DOUBLE), DIMENSION(MMAX) :: YC REAL(DOUBLE), DIMENSION(NFIT) :: AMP_Y REAL(DOUBLE), DIMENSION(NMONSM) :: Y_INFTY, DELTA_Y REAL(DOUBLE), DIMENSION(MAXSPE) :: ZSHIFTSAV REAL(DOUBLE), DIMENSION(NFIT) :: WAVE_X REAL(DOUBLE) :: DEL, SUMSQ, WSCALE, DWAVE, DSHIFT, FRACS, PHI, SMM, YS, & BKGND, YCAVE, FX, TEMPP !, STDEV COMPLEX(DBLE_COMPLEX) :: TCALL, TCALH, TCALI ! --- PARAMETER INCREMENT FOR PARTIALS DATA DEL/0.1D-05/ COMPLEX(DBLE_COMPLEX), DIMENSION(:), ALLOCATABLE :: TCONVSAV INTEGER :: NAERR ! ----------------------------------------------------------- ! COMPUTES MONOCHROMATIC SPECTRUM, CONVOLVES WITH INSTRUMENTAL ! PROFILE, AND FINDS OBSERVED MINUS CALCULATED AMPLITUDES ! AT ALL POINTS - ! COMPUTE NEW SPECTRUM (IPARM=1) WITH UPDATED XN ! THEN COMPUTE KN (NVAR X NFIT) FOR NEXT ITERATION ! OUTER LOOP - NVAR INNER LOOP NFIT ! ----------------------------------------------------------- !nbkfit nshift nzero nsolar neaprt nephsrt ndiff nphase nret*(kmax||1) ntemp channels ! do fft ismix TFLG = .FALSE. BUG1 = .FALSE. !.TRUE. IF (KFLG) THEN NVAR1 = NVAR + 1 ELSE NVAR1 = 1 ENDIF IF (OUTPUT_CHANNEL_FILES) THEN !for_channel_value_files IF (ITER == 1) CALL FILEOPEN(30, 1 ) IF (ITER == 2) CALL FILEOPEN(40, 1 ) ENDIF PARAM: DO ICOUNT = 1, NVAR1 KFIT = 0 KFIT2 = 0 KZERO = 0 KPHASE = 0 JATMOS = 0 SUMSQ = 0.D0 IPARM = 0 IF( ICOUNT .GT. 1 )IPARM = ICOUNT -1 IF( BUG1 )PRINT *,'' IF( BUG1 )WRITE(0,202) 'TOP : ', ITER, ICOUNT, IPARM ! --- RESET PARM TO PERTURB EACH INDIVIDUALLY PARM(:NVAR) = XN IF (ICOUNT .GT. 1) THEN PARM(IPARM) = PARM(IPARM) + DEL IF( BUG1 )WRITE(0,203) ' PARM: ', IPARM, PNAME(IPARM), PARM(IPARM)-del, PARM(IPARM) ENDIF ! --- ADJUST THESE PARAMETERS IN BAND/SPEC LOOPS BELOW NCOUNT = NBKFIT + NSHIFT + NZERO ! --- SOLAR SPECTRUM PARAMETERS IF( IFCO )THEN DO I = 1, 5 IF( ICFIX(I) )THEN NCOUNT = NCOUNT + 1 CPARM(I) = PARM(NCOUNT)*CIPARM(I) !print *, ncount, nsolar1, parm(ncount) ENDIF END DO ENDIF ! --- EMPIRICAL APODIZATION IF (NEAPRT /= 0) THEN IF (NEAPRT > 0) THEN EAPF(:NEAPRT) = EAPF0(:NEAPRT)*PARM(NCOUNT+1:NEAPRT+NCOUNT) NCOUNT = NEAPRT + NCOUNT ENDIF ENDIF ! --- EMPIRICAL PHASE FUNCTION IF (NEPHSRT /= 0) THEN IF (NEPHSRT > 0) THEN EPHSF(:NEPHSRT) = EPHSF0(:NEPHSRT)*PARM(NCOUNT+1:NEPHSRT+NCOUNT) NCOUNT = NEPHSRT + NCOUNT ENDIF ENDIF ! --- UPDATE DIFFERENTIAL SHIFT IF (NDIFF /= 0) THEN IF (NDIFF > 0) THEN ISHIFT(:NDIFF) = NINT(PARM(NCOUNT+1:NDIFF+NCOUNT)/.6D-06) NCOUNT = NDIFF + NCOUNT ENDIF ENDIF ! --- UPDATE NCOUNT INDEX TO INCLUDE PHASE ERROR PARAMETERS NCOUNT = NCOUNT + NPHASE ! --- UPDATE VMRS OF RETRIEVAL GASES DELTA_Y(:NFIT) = 0.0D0 DELTA_Y(:NMONSM) = 0.0D0 XRET = .FALSE. DO KK = 1, NRET IF( IFPRF(KK) )THEN K = ICOUNT-NCOUNT-1 IF( ANALYTIC_K .AND. K .GT. 0 .AND. K .LT. KMAX+1 )THEN ! K-MATRICES ARE CALCULATED SEMI-ANALYTICALLY. ! THIS IS WAY FASTER. XRET=.TRUE. IF (IEMISSION/=0) THEN IF (K.GT.1) THEN DELTA_Y(:NMONSM) = & - CROSS_FACMAS(KK,K,:NMONSM) * (TCALC_E(2,:NMONSM, KMAX+1) & + TCALC_S(2,:NMONSM,K-1) - TCALC_E(2,:NMONSM,K)) ELSE DELTA_Y(:NMONSM) = -CROSS_FACMAS(KK,K,:NMONSM)* TCALC_E(2,:NMONSM, KMAX+1) ENDIF ELSE DELTA_Y(:NMONSM) = -CROSS_FACMAS(KK,K,:NMONSM)*Y_INFTY(:NMONSM) ENDIF IF( ILOGRETRIEVAL(KK)/=0 )THEN ! THE KMATRIX IS ANALYTICALLY CALCULATED, ! NEED THE ORIGINAL STATE VECTOR PARM(IPARM) = XN(IPARM) X(KK,:KMAX) = EXP(PARM(NCOUNT+1:KMAX+NCOUNT)) DELTA_Y(:NMONSM) = DELTA_Y(:NMONSM) / XORG(KK,K) * X(KK,K) ENDIF ELSEIF( ILOGRETRIEVAL(KK) /= 0 )THEN X(KK,:KMAX) = EXP(PARM(NCOUNT+1:KMAX+NCOUNT)) ELSE X(KK,:KMAX) = PARM(NCOUNT+1:KMAX+NCOUNT)*XORG(KK,:KMAX) ENDIF NCOUNT = NCOUNT + KMAX ELSE ! --- SCALING VERTICAL DISTRIBUTION NCOUNT = NCOUNT + 1 X(KK,:KMAX) = PARM(NCOUNT)*XORG(KK,:KMAX) ENDIF END DO ! --- TEMPERATURE RETRIEVAL IF( IFTEMP ) THEN !IF( BUG1 )PRINT *, IFTEMP, IPARM, NCOUNT, NTEMP1, NTEMP, PARM(NCOUNT+1:NCOUNT+1) TRET = .FALSE. ! --- ONLY CONSIDERING SCALE OR FIT EACH LAYER IF( NTEMP .EQ. KMAX )THEN K = IPARM - NCOUNT IF( K .GE. 1 .AND. K .LE. KMAX )THEN !IF( NCOUNT+1 .GE. NTEMP1 .AND. NCOUNT+1 .LT. NTEMP1 + NTEMP )THEN TRET = .TRUE. !print*, k, t(k), torg(k) T(:KMAX) = PARM(NCOUNT+1:NCOUNT+NTEMP) * TORG(:KMAX) !print*, k, t(k), torg(k), ITER, KMAX NCOUNT = NCOUNT + KMAX !IF( ITER .NE. -1 )THEN CALL LBLATM( ITER, KMAX ) CALL SETUP3( .FALSE., K ) !ENDIF ! ITER ENDIF ! K ELSE IF( IPARM .EQ. NTEMP1 )THEN ! .AND. IPARM .LE. NTEMP1+2 )THEN !PRINT*, ' INSIDE ', IPARM, NCOUNT, NTEMP1, PARM(NCOUNT+1) TRET = .TRUE. NCOUNT = NCOUNT + 1 T(:KMAX) = PARM(NCOUNT) * TORG(:KMAX) IF( ITER .NE. -2 )THEN CALL LBLATM( ITER, KMAX ) CALL SETUP3( .FALSE., -1 ) ENDIF ! ITER ENDIF ! IPARM !write(0,'(2f14.5)') (t(kk),torg(kk), kk=1,kmax) ENDIF ! IFTEMP ! --- UPDATE TO SOLAR SPECTRAL CALCULATIONS - ALL BANDS AT ONCE IF (NSOLAR /= 0) THEN IF (IPARM == 0) GO TO 6 IF ((IPARM .LT. NSOLAR1) .OR. (IPARM .GE. NSOLAR1+NSOLAR)) GOTO 7 6 CONTINUE IF( BUG1 )PRINT *,' SOLSARFH', IPARM, NSOLAR1, NSOLAR CALL SOLARFH( 1 ) ENDIF ! --- SKIP OVER MONOCHROMATIC CALCULATIONS IF NOT REQUIRED 7 CONTINUE IF (IPARM == 0) GO TO 8 ! --- DO NOT CALCULATE SPECTRUM IF NOT NECESSARY. NCOUNT = NBKFIT + NSHIFT + NZERO + NSOLAR + NEAPRT + NEPHSRT + NPHASE ! + NDIFF IF( BUG1 )PRINT *, ' IPARM, NCOUNT : ', IPARM, NCOUNT IF (IPARM .LT. NCOUNT) GO TO 9 ! --- COMPUTE MONOCHROMATIC TRANSMITTANCES ! --- ANAYLITC K-MATICES MAY BE CHOSEN IN PARAM_M.F90 MP 8 CONTINUE IF ((.NOT.ANALYTIC_K).OR.(.NOT.XRET).OR.(TRET).OR.(ICOUNT.EQ.1)) THEN CALL TALL IF( BUG1 )PRINT*, ' TALL', IPARM !print*, nmonsm, TCALC(1,:100) !stop ELSE IF( BUG1 )PRINT*, ' TALL/DIFF', IPARM ! THERE COME SOME MORE OPERATIONS ON THE NEW SPECTRUM. ! NOT YET INVESTIGATED WHICH ARE LINEAR. ! DECREASE NEW SPECTRUM BY DEL, WORKS MORE EXACT WITH FURTHER ! OPERATIONS. MAY BE REMOVED LATER ON. MP TCALC(1,:NMONSM) = Y_INFTY(:NMONSM) + DELTA_Y(:NMONSM)*DEL TCALC(2,:NMONSM) = TCALC(1,:NMONSM) END IF IF (ICOUNT.EQ.1) Y_INFTY(:NMONSM) = TCALC(2,:NMONSM) 9 CONTINUE MONONE = 1 MXONE = 1 ! --- RETRIEVE CHANNEL PARMS FROM STATE VECTOR-----------------------------!PWJ CALL RETRIEVE_CHANNEL_PARMS (PARM) ! --- LOOP OVER BANDPASSES ---------------------------------------------------- BAND: DO IBAND = 1, NBAND N = NSCAN(IBAND) IF (N == 0) CYCLE ! --- LOOP OVER SPECTRA ------------------------------------------------------- SPEC: DO JSCAN = 1, N ! --- DETERMINE CURRENT BACKGROUND PARAMETERS CORRESPONDING ! --- TO SPECTRUM AND BANDPASS B(1) = 1.0D0 IF (NBACK <= 1) THEN B(2) = 0.D0 B(3) = 0.D0 ELSE KFIT = KFIT + 1 B(2) = PARM(KFIT) IF (NBACK <= 2) THEN B(3) = 0.D0 ELSE KFIT = KFIT + 1 B(3) = PARM(KFIT) ENDIF ENDIF ! --- DETERMINE CURRENT WAVENUMBER SCALE MULTIPLIER IF (ISPARM /= 2) THEN IF (ISPARM == 0) GO TO 3 IF (ISPARM == 3) GO TO 131 ! --- SINGLE PARAMETER FOR ALL BANDPASSES WSCALE = PARM(NBKFIT+1) GO TO 14 ENDIF ! --- INDEPENDENT PARAMETER FOR EACH BANDPASS WSCALE = PARM(NBKFIT+IBAND) GO TO 14 ! --- INDEPENDENT PARAMETER FOR EACH FIT 131 CONTINUE KFIT2 = KFIT2 + 1 WSCALE = PARM(NBKFIT+KFIT2) GO TO 14 ! --- NO WAVENUMBER SHIFT 3 CONTINUE WSCALE = 0.0D0 ! --- CALCULATE SHIFT IN WAVENUMBERS 14 CONTINUE DWAVE = 0.5D0*(WAVE3(IBAND)+WAVE4(IBAND))*((WAVFAC(IBAND) + WSCALE) - 1.D0) ! --- CALCULATE NUMBER OF MONOCHROMATIC POINTS TO SHIFT DSHIFT = DWAVE/DN(IBAND) MSHIFT = NINT(DSHIFT) FRACS = DSHIFT - MSHIFT ! --- DETERMINE ZERO LEVEL OFFSET TO APPLY IF (IZERO(IBAND) == 1) THEN ! kzero increments for each band KZERO = KZERO + 1 ZSHIFT(IBAND,JSCAN) = PARM(NBKFIT+NSHIFT+KZERO) ZSHIFTSAV(JSCAN) = ZSHIFT(IBAND,JSCAN) ELSE IF (IZERO(IBAND) == 2 ) THEN ! if we're not calculating it then use shift from band from this spec that we are fitting ZSHIFT(IBAND,JSCAN) = ZSHIFTSAV(JSCAN) ENDIF ! --- DETERMINE PHASE ERROR TO APPLY PHI = 0.D0 IF( IFPHASE )THEN KPHASE = KPHASE + 1 PHI = PARM(NBKFIT+NSHIFT+NZERO+NEAPRT+NEPHSRT+NSOLAR+NDIFF+KPHASE) ENDIF ! --- COMPUTE FFTS IF REQUIRED IF (IPARM == 0) GO TO 15 NCOUNT = NBKFIT + NSHIFT + NZERO IF (IPARM <= NCOUNT) GO TO 16 15 CONTINUE IF( BUG1 )PRINT *, ' FSPEC...', IPARM CALL FSPEC1 (IBAND, MONONE, MXONE) CALL FSPEC2 (IBAND, MONONE, PHI) ! --- COMPUTE RESIDUALS 16 CONTINUE N1 = NSTART(IBAND) + MSHIFT + MONONE - 1 N2 = N1 + (NPRIM(IBAND)-1)*NSPAC(IBAND) ! --- CHECK FOR TCALC OVERFLOW OF BAND SPACE IF (N1=MONONE+NM(IBAND)) GO TO 17 N3 = NPRIM(IBAND) SMM = 0.D0 DO J = 1, N3 I = N1 + (J - 1)*NSPAC(IBAND) JATMOS = JATMOS + 1 TCALL = TCONV(I) TCALH = TCONV(I+1) TCALI = TCALL + FRACS*(TCALH - TCALL) YS = (J - 1)*SPAC(IBAND) WAVE_X(JATMOS) = YS + WSTART(IBAND) BKGND = B(1)*(1.0D0 + B(2)*YS+B(3)*YS*YS) BKGND = BKGND*(1.0D0/(1.0D0 + ZSHIFT(IBAND,JSCAN))) !-- FIT CHANNEL PARMS IF NEEDED ----------------------------------------!PWJ IF (NBEAM_OF_BAND(IBAND) /= 0) THEN YC(JATMOS) = FIT_CHANNEL_PARMS(IBAND,JSCAN,J,DBLE(BKGND),TCALI,TEMPP) IF (OUTPUT_CHANNEL_FILES) THEN AMP_Y(JATMOS) = TEMPP !for_channel_value_files ENDIF ELSE YC(JATMOS) = BKGND*(DBLE(TCALI) + ZSHIFT(IBAND,JSCAN)) ENDIF SMM = SMM + YC(JATMOS) END DO ! -- normalization of spectra only when absorption ! spectra only or normalization is explicitely ! required for emission spectra. mp IF (.NOT.IEMISSION/=0 .OR. IENORM(IBAND)/=0) THEN YCAVE = SMM/N3 YC(JATMOS-N3+1:JATMOS) = YC(JATMOS-N3+1:JATMOS)/YCAVE ELSE YCAVE = 1.0D0 END IF IF( F_WRTGASFILES )THEN ! SAVE TCALC ALLOCATE (TCONVSAV(NMONSM), STAT=NAERR) IF (NAERR /= 0) THEN WRITE (6, *) 'COULD NOT ALLOCATE TCONVSAV ARRAY' WRITE (6, *) 'ERROR NUMBER = ', NAERR STOP 'SETUP ALLOCATION' ENDIF TCONVSAV(:NMONSM) = TCONV(:NMONSM) TCALC(1,:NMONSM) = TCALC(2,:NMONSM) ! TEMPORARILY TURN OF FLAG SO FSPEC1 WILL NOT APPLY TCO IFCOSAVE = IFCO IFCO = .FALSE. IF (GASOUTTYPE == 1) THEN WRITE(GASFNAME,610)IBAND,JSCAN ELSE IF (iter == -1) THEN WRITE(GASFNAME,610)IBAND,JSCAN ELSE WRITE(GASFNAME,620)IBAND,JSCAN,ITER ENDIF ENDIF WRITE(TITLE,630) OPEN(UNIT=80, FILE=GASFNAME, STATUS='REPLACE', ERR=555) WRITE (80, 640) TITLE WRITE (80, *) WSTART(IBAND), WSTOP(IBAND), SPAC, N3 DO iii=JATMOS-N3+1,JATMOS WRITE (80, *) YC(iii) ENDDO CLOSE (80) DO NR = 1, NRETB(IBAND) CALL GASNTRAN(NR,IBAND,JSCAN,2,MONONE,MXONE) ! --- COMPUTE FFTS CALL FSPEC1 (IBAND, MONONE, MXONE) CALL FSPEC2 (IBAND, MONONE, PHI) IF (GASOUTTYPE == 1) THEN WRITE(GASFNAME,690) TRIM(GASB(IBAND,NR)),IBAND,JSCAN ELSE IF (iter == -1) THEN WRITE(GASFNAME,690) TRIM(GASB(IBAND,NR)),IBAND,JSCAN ELSE WRITE(GASFNAME,700) TRIM(GASB(IBAND,NR)),IBAND,JSCAN,ITER ENDIF ENDIF WRITE(TITLE,710) TRIM(GASB(IBAND,NR)), IBAND, JSCAN, ITER OPEN(UNIT=80, FILE=GASFNAME, STATUS='REPLACE', ERR=555) WRITE (80, 640) TITLE WRITE (80, *) WSTART(IBAND), WSTOP(IBAND), SPAC(IBAND), N3 DO J = 1, N3 I = N1 + (J - 1)*NSPAC(IBAND) WRITE (80, *) DBLE(TCONV(I)) ENDDO CLOSE (80) ENDDO IFCO = IFCOSAVE IF( IFCO )THEN CALL ZERONTRAN( IBAND, 2, MONONE ) ! --- COMPUTE FFTS CALL FSPEC1 (IBAND, MONONE, MXONE) CALL FSPEC2 (IBAND, MONONE, PHI) IF (GASOUTTYPE == 1) THEN WRITE(GASFNAME,730)IBAND,JSCAN ELSE IF (ITER == -1 ) then WRITE(GASFNAME,730)IBAND,JSCAN ELSE WRITE(GASFNAME,740)IBAND,JSCAN,ITER ENDIF ENDIF WRITE(TITLE,750) OPEN(UNIT=80, FILE=GASFNAME, STATUS='REPLACE', ERR=555) WRITE (80, 640) TITLE WRITE (80, *) WSTART(IBAND), WSTOP(IBAND), SPAC(IBAND), N3 DO J = 1, N3 I = N1 + (J - 1)*NSPAC(IBAND) WRITE (80, *) DBLE(TCONV(I)) ENDDO CLOSE (80) ENDIF GOTO 557 ! File Open Error handler 555 CONTINUE WRITE (6, 556) 557 CONTINUE IFCO=IFCOSAVE ! RESTORE TCALC TCALC(2,:NMONSM) = TCALC(1,:NMONSM) TCONV(:NMONSM) = TCONVSAV(:NMONSM) DEALLOCATE (TCONVSAV) ENDIF ! WRITE GASOUT FILES MONONE = MONONE + NM(IBAND) ! UP BAND WIDTH FOR EACH SCAN END DO SPEC MXONE = MXONE + NM(IBAND) ! INDEX IN TCO AND CROSS ARRAYS AS START OF CURRENT BAND END DO BAND DO I = 1, NFIT FX = TOBS(I) - YC(I) SUMSQ = SUMSQ + FX*FX END DO IF (ICOUNT .EQ. 1) THEN RMS = 100.D0*SQRT(SUMSQ/NFIT) IF( ITER .LT. 0 ) THEN WRITE (16, 27) SNR, RMS, NVAR, NFIT WRITE (*, 27) SNR, RMS, NVAR, NFIT ELSE WRITE (16, 26) ITER, SNR, RMS, NVAR, NFIT WRITE (*, 26) ITER, SNR, RMS, NVAR, NFIT ENDIF WRITE (16, 888) (PARM(I),I=1,NVAR) IF (OUTPUT_CHANNEL_FILES) THEN IF (ITER == 1) THEN !for_channel_value_files WRITE (30, 3000) (WAVE_X(I),AMP_Y(I),I=1,NFIT) CALL FILECLOSE( 30, 1) ENDIF IF (ITER == 2) THEN !for_channel_value_files WRITE (40, 3000) (WAVE_X(I),AMP_Y(I),I=1,NFIT) CALL FILECLOSE( 40, 1 ) ENDIF ENDIF ! --- UPDATE CALCULATED SPECTRUM ARRAY ON FIRST TRIP THROUGH UPDATE SPECTRA YN = YC(:NFIT) ELSE ! --- UPDATE ARRAY OF PARTIAL DERIVATIVES !IF (ANALYTIC_K.AND.XRET) THEN ! KN(:NFIT,IPARM) = (YC(:NFIT)-YN)/DEL !ELSE KN(:NFIT,IPARM) = (YC(:NFIT)-YN)/DEL !END IF IF( BUG1 ) & WRITE(0,204) ' KN: ', ICOUNT, IPARM, PARM(IPARM), SUM(KN(:NFIT,IPARM))/REAL(NFIT,8), SQRT(SUM(KN(:NFIT,IPARM)**2)) !write(0,'(10(e11.4,1x))'), kn(:nfit,iparm) !write(0,'(10(e11.4,1x))'), !if(iparm .eq. 4)write(0,'(4d22.14)') (yc(kk), yn(kk), yc(kk)-yn(kk), (yc(kk)-yn(kk))/del, kk=1,nfit) ENDIF END DO PARAM ! --- ZERO K MATRIX FOR MOLECULES NOT INCLUDED IN FIT OF A BAND BAND1: DO IBAND = 1, NBAND NS = NSCAN(IBAND) IF (NS == 0) CYCLE IF( IBAND > 1 ) THEN NS1 = SUM(NPRIM(1:IBAND-1))+1 NS2 = SUM(NPRIM(1:IBAND)) ELSE NS1 = 1 NS2 = SUM(NPRIM(1:IBAND)) ENDIF SPEC1: DO JSCAN = 1, NS NR = NRETB(IBAND) RET1: DO KK = 1, NRET IF( NGIDX(KK,0,IBAND) == 0 ) THEN KN( NS1:NS2 , NGIDX(KK,1,0): NGIDX(KK,2,0) ) = 0.0D0 ELSE ENDIF END DO RET1 END DO SPEC1 END DO BAND1 ! --- PRINT OUT PARM ARRAY WRITE(89,164) ITER, PARM(:NVAR) RETURN 17 CONTINUE WRITE (16, 18) N1, N2, IBAND, NSTART(IBAND), MSHIFT, MONONE, NPRIM(IBAND)& , NSPAC(IBAND) WRITE (16,*) "WAVENUMBER SHIFT OUT OF SPECTRAL RANGE." TFLG=.TRUE. RETURN 18 FORMAT(/,' !!! ABORT !!! TCALC ARRAY OVERFLOW : ',/,' N1 =',I10, & ' N2 =',I10,' IBAND =',I6,/,' NSTART=',I6,' MSHIFT=',I10, & ' MONONE=',I6,/,' NPRIM =',I6,' NSPAC =',I6) 26 FORMAT(/,' ITER=',I2,' AVGSNR=',F12.4,' RMS(%)=',F10.7,' NVAR=',I3,' NFIT=',I6) 27 FORMAT(/,' FINAL: AVGSNR=',F12.4,' RMS(%)=',F10.7,' NVAR=',I3,' NFIT=',I6) !162 FORMAT(/,' EFFECTIVE APODIZATION PARAMETER =',F8.3) !163 FORMAT(F8.3) 164 FORMAT( i5, 255ES26.18 ) !201 FORMAT(A, 2I5, 2X, E14.6, 3F15.7) 202 FORMAT(A, 3I5, 2X, A10, E14.6, 3F14.8) 203 FORMAT(A, I5, 2X, A, 3F14.6) 204 FORMAT(A, 2I5, 2X, E14.6, 3D16.8) 556 FORMAT(/,' COULD NOT CREATE INDIVIDUAL GAS FILE') 610 FORMAT('allgases.',I2.2,'.',I2.2,'.FINAL') 620 FORMAT('allgases.',I2.2,'.',I2.2,'.',I2.2) 630 FORMAT('SFIT2 ALLGASES file') 640 FORMAT(A80) 690 FORMAT('gas.',a,'.',I2.2,'.',I2.2,'.FINAL') 700 FORMAT('gas.',a,'.',I2.2,'.',I2.2,'.',I2.2) 710 FORMAT('GAS ',a7,' BAND ', I2, ' SCAN ', I2, ' ITER ', I3) 730 FORMAT('solar.',I2.2,'.',I2.2,'.FINAL') 740 FORMAT('solar.',I2.2,'.',I2.2,'.',I2.2) 750 FORMAT('SFIT2 SOLAR file') 888 FORMAT(5(1P,E14.7,1X)) 3000 FORMAT(2(E14.6)) END SUBROUTINE FM END MODULE FRWDMDL