MODULE INITIALIZE USE PARAMS USE RETVPARAM USE TRANSMIS USE MOLCPARAM USE XSECTIONS USE DATAFILES USE SYNSPEC USE LINEPARAM USE BANDPARAM USE RAYTRACE USE SOLAR IMPLICIT NONE LOGICAL :: RETFLG INTEGER :: NSTNR = 0 INTEGER :: ISOFLAG, IPFLAG INTEGER :: IRTEPHS, IRTEAP !REAL(DOUBLE) ::SNR !REAL(DOUBLE), DIMENSION(MAXBND) :: BSNR REAL(DOUBLE) :: SPHS, PHS, SCOPAR, COPAR, & SBCKOFF, BCKOFF, SBCKCRV, BCKCRV, SBCKSL, BCKSL, & SWSHFT, WSHFT, TOL REAL(DOUBLE), DIMENSION(MMAX) :: WWV REAL(DOUBLE), DIMENSION(MAXSNR) :: WWV0, WWV1, GSTNR CONTAINS !---------------------------------------------------------------------- SUBROUTINE SETUP1 ! --- SETUP CALCULATIONS FOR THE VARIOUS BANDPASSES INTEGER :: IBAND, NEXTRA, NAERR, MAXMPT REAL(DOUBLE) :: DWAVE, WAVE1, WAVE2, AN ! --- READ DATA FOR EACH BANDPASS. STORE IN ARRAY TOBS ! --- ALSO TABULATE LIST OF SCANS BEING FIT IN EACH REGION ! NSCAN(IBAND) = NUMBER OF SCANS TO BE FIT FOR BANDPASS IBAND ! ISCAN(IBAND,I)) = SPECTRUM INDEX FOR THE ITH SCAN FITTED CALL GETSPEC() WRITE(16,105) NATMOS ! --- COMPUTE INTERVAL FOR MONOCHROMATIC CALCULATIONS FOR EACH BANDPASS ! ADD ABOUT 10 TIMES THE RESOLUTION TO BOTH SIDES OF THE INTEGRATION ! INTERVAL TO ALLOW FOR WAVELENGTH SHIFTS MAXMPT = 0 WRITE (16, 200) DO IBAND = 1, NBAND IF (NSCAN(IBAND) == 0) CYCLE DWAVE = 10.D0/PMAX(IBAND) NEXTRA = NINT( DWAVE/DN(IBAND)) WAVE1 = WSTART(IBAND) - NEXTRA*DN(IBAND) WAVE2 = WSTOP(IBAND) + NEXTRA*DN(IBAND) NSTART(IBAND) = NEXTRA + 1 WMON(IBAND) = WAVE1 NM(IBAND) = FLOOR((WAVE2 - WAVE1)/DN(IBAND) + 1.000000001D0) ! --- INTERVAL FOR INPUT OF LINE DATA WAVE5(IBAND) = WAVE1 - DLINES WAVE6(IBAND) = WAVE2 + DLINES ! --- ESTIMATE 2**M FOR FFT AN = NM(IBAND) MFFT(IBAND) = FLOOR(LOG(AN)/LOG(2.0D0)) + 1 MPT(IBAND) = 2**MFFT(IBAND) IF (MPT(IBAND) > MAXMPT) MAXMPT = MPT(IBAND) LOWFIL(IBAND) = (MPT(IBAND)-NM(IBAND))/2 HIFILL(IBAND) = LOWFIL(IBAND) + NM(IBAND) NSTZ1(IBAND) = FLOOR(DN(IBAND)*PMAX(IBAND)*MPT(IBAND)) + 1 NSTZ2(IBAND) = MPT(IBAND) - NSTZ1(IBAND) WRITE (16, 201) WSTART(IBAND), WSTOP(IBAND), NM(IBAND), MPT(IBAND), NSTZ1(IBAND), NSTZ2(IBAND) END DO ! --- COUNT TOTAL NUMBER OF MONOCHROMATIC POINTS (NMONSM) ! --- AND THE TOTAL NUMBER OF CROSS SECTION POINTS (NCROSS) ! --- TO BE CALCULATED AND CHECK FOR ARRAY OVERFLOWS NMONSM = 0 NCROSS = 0 NCROSS = SUM(NM(:NBAND)) NMONSM = DOT_PRODUCT(NM(:NBAND),NSCAN(:NBAND)) ALLOCATE (CROSS(NRET+1,KMAX,NCROSS), STAT=NAERR) IF (NAERR /= 0) THEN WRITE (6, *) 'Could not allocate CROSS array' WRITE (6, *) 'Error Number = ', NAERR STOP 'SETUP ALLOCATION' ENDIF ALLOCATE (CROSS_FACMAS(NRET+1,KMAX,NMONSM), STAT=NAERR) IF (NAERR /= 0) THEN WRITE (6, *) 'Could not allocate CROSS_FACMAS array' WRITE (6, *) 'Error Number = ', NAERR STOP 'SETUP ALLOCATION' ENDIF ALLOCATE (TCO(NCROSS), STAT=NAERR) IF (NAERR /= 0) THEN WRITE (6, *) 'Could not allocate TCO array' WRITE (6, *) 'Error Number = ', NAERR STOP 'SETUP ALLOCATION' ENDIF ALLOCATE (TCONV(NMONSM),STAT=NAERR) IF (NAERR /= 0) THEN WRITE (6, *) 'Could not allocate TCONV array' WRITE (6, *) 'Error Number = ', NAERR STOP 'SETUP ALLOCATION' ENDIF ALLOCATE (TCALC(2,NMONSM), STAT=NAERR) IF (NAERR /= 0) THEN WRITE (6, *) 'Could not allocate TCALC array' WRITE (6, *) 'Error Number = ', NAERR STOP 'SETUP ALLOCATION' ENDIF ALLOCATE (TCALC_I(2,NMONSM), STAT=NAERR) IF (NAERR /= 0) THEN WRITE (6, *) 'Could not allocate TCALC_I array' WRITE (6, *) 'Error Number = ', NAERR STOP 'SETUP ALLOCATION' ENDIF ALLOCATE (IMGG(MAXMPT), STAT=NAERR) IF (NAERR /= 0) THEN WRITE (6, *) 'Could not allocate IMGG array' WRITE (6, *) 'Error Number = ', NAERR STOP 'SETUP ALLOCATION' ENDIF ALLOCATE (TCALC_E(2,NMONSM, KMAX+1), STAT=NAERR) IF (NAERR /= 0) THEN WRITE (6, *) 'Could not allocate TCALC_E array' WRITE (6, *) 'Error Number = ', NAERR STOP 'SETUP ALLOCATION' ENDIF ALLOCATE (TCALC_S(2,NMONSM, KMAX), STAT=NAERR) IF (NAERR /= 0) THEN WRITE (6, *) 'Could not allocate TCALC_E array' WRITE (6, *) 'Error Number = ', NAERR STOP 'SETUP ALLOCATION' ENDIF WRITE (16, 212) NMONSM, NCROSS RETURN 105 FORMAT(/,' TOTAL NUMBER OF SPECTRAL DATA POINTS TO FIT =',I6) 200 FORMAT(/,' WSTART WSTOP NMON MPT NSTZ1 NSTZ2') 201 FORMAT(2F10.4,I8,I7,2I9) 212 FORMAT(/,' NMONSM =',I8,/,& ' NCROSS =',I8) END SUBROUTINE SETUP1 SUBROUTINE SETUP2 CHARACTER *64 :: ILSHEAD INTEGER :: I, J, K REAL(DOUBLE) :: DUMMY ! ---- STORE CO LINE LIST IF( IFCO )THEN WRITE (*, *) ' READING SOLAR LINE LIST FILE...' CALL SOLARFH( 0 ) ! ---- IF NO SOLAR CO LINES FOUND, RESET IFCO=0 IF (NCOLNS == 0) IFCO = .FALSE. ! --- DEFAULT VALUES TO ZERO IN CASE PRINT BELOW EAPX(:MAXEAP) = 0.0 EAPF(:MAXEAP) = 0.0 EPHSX(:MAXEAP) = 0.0 EPHSF(:MAXEAP) = 0.0 ENDIF ! --- IF USING EMPIRICAL APODIZATION, READ PARAMETERS IF (IEAP > 0) THEN WRITE (*, *) ' READING EMPIRICAL MODULATION PARAMETER FILE...' CALL FILEOPEN( 23, 3 ) IF (IEAP == 4) THEN ! READS LINEFIT FORMAT ASSUMES 20 VALUES) JEAP = 20 READ (23, '(A64)') ILSHEAD ! DON'T READ EPHS HERE SINCE THERE COULD BE TWO DIFFERENT FILES READ (23, *, ERR=120) (EAPX(I),EAPF(I),DUMMY,I=1,JEAP) ELSE ! ORIGINAL FILE FORMAT READ (23, *) JEAP READ (23, *) (EAPF(I),I=1,JEAP) WRITE (16, '(/A)') 'EMPIRICAL MODULATION FUNCTION COEFFICIENTS' WRITE (16, *) (EAPF(I),I=1,JEAP) IF (IEAP == 1) THEN READ (23, *) (EAPX(I),I=1,JEAP) WRITE (16, *) (EAPX(I),I=1,JEAP) ENDIF ENDIF CALL FILECLOSE(23, 2) ENDIF ! --- IF USING EMPIRICAL PHASE FUNCTION, READ PARAMETERS IF (IEPHS > 0) THEN WRITE (*, *) ' READING EMPIRICAL PHASE FUNCTION FILE...' CALL FILEOPEN(24, 3) IF (IEPHS == 4) THEN ! READS LINEFIT FORMAT ASSUMES 20 VALUES) JEPHS = 20 READ (24, '(A64)') ILSHEAD ! DON'T READ EAPF HERE SINCE THERE COULD BE TWO DIFFERENT FILES READ (24, *, ERR=125) (EPHSX(I),DUMMY,EPHSF(I),I=1,JEPHS) ELSE ! ORIGINAL FILE FORMAT READ (24, *) JEPHS READ (24, *) (EPHSF(I),I=1,JEPHS) WRITE (16, '(/A)') 'EMPIRICAL PHASE FUNCTION COEFFICIENTS' WRITE (16, *) (EPHSF(I),I=1,JEPHS) IF (IEPHS == 1) THEN READ (24, *) (EPHSX(I),I=1,JEPHS) WRITE (16, *) (EPHSX(I),I=1,JEPHS) ENDIF ENDIF CALL FILECLOSE(24,2) ENDIF IF (IEAP==4 .OR. IEPHS==4) THEN ! IF USING BOTH IEAP=4 OR IEPHS=4 PRINT AS FOUND IN ONE FILE ! WHICH ASSUMES EAPX IS THE SAME AS EPHSX WRITE (16, 202) JEAP WRITE (16, 203) (EPHSX(I),EAPF(I),EPHSF(I),I=1,JEAP) ENDIF ! --- INPUT ATMOSPHERIC LINE DATA FROM TAPE14 WRITE (*, *) ' READING ATMOSPHERIC LINE LIST FILE...' CALL OPTLIN ! --- PRINT OUT T-DEPENDENCE OF HALFWIDTHS ! WRITE(16,3661) ! WRITE(16,3662) (NAME(ICODE(I)),THALF(ICODE(I)),I=1,NGAS) ! --- FOR EACH GAS, IDENTIFY IF IT IS A RETRIEVAL GAS. IF IT IS, ! STORE THE STARTING PROFILE IN ARRAY XORG DO J = 1, NRET DO I = 1, NGAS IF (IGAS(J) == ICODE(I)) GO TO 232 END DO WRITE (16, 3663) J STOP 232 CONTINUE IRET(J) = I ! --- CHECK FOR A 0.0 IN AN INITIAL PROFILE TO BE RETRIEVED DO K = 1, KMAX IF (XGAS(I,K) <= 0.0D0) GO TO 107 X(J,K) = XGAS(I,K) XORG(J,K) = XGAS(I,K) END DO END DO IF( NRET .EQ. 0 )THEN X(1,:KMAX) = 1.0D0 XORG(1,:KMAX) = 1.0D0 ENDIF PLANCK_C1 = 2.0D0 * C_PLANCK * V_LIGHT ** 2.0D0 * 100.0D0 ** 4.0D0 PLANCK_C2 = 100.0D0 * C_PLANCK * V_LIGHT / C_BOLTZ RETURN 107 CONTINUE WRITE (16, 668) NAME(ICODE(I)) CLOSE(16) STOP 'ABORT !!! SETUP' 120 CONTINUE WRITE (16, 130) JEAP, TFILE(23) CLOSE(16) 125 CONTINUE WRITE (16, 135) JEPHS, TFILE(24) CLOSE(16) STOP 'ABORT !!! SETUP' 130 FORMAT(/,' ABORT -SETUP- ERROR READING EAP FILE. ',I5,' VALUE REQUIRED',/& ,' FILENAME: "',A,'"') 135 FORMAT(/,' ABORT -SETUP- ERROR READING EPHS FILE. ',I5,' VALUE REQUIRED',& /,' FILENAME: "',A,'"') 202 FORMAT(/,' TABULAR FORM OF ILS PARAMETERS, ASSUMING N= ',I3,/,& ' OPD MODULATION PHASE') 203 FORMAT(F7.3,2ES12.4) 668 FORMAT(/,' ABORT -SETUP2- ZERO VMR VALUE FOUND IN PROFILE: ',A7) ! 3661 FORMAT(/,/,' TEMPERATURE DEPENDENCE OF HALFWIDTHS',/,' GAS TDEP'/) ! 3662 FORMAT(1X,A7,F6.2) 3663 FORMAT(/,' ABORT -SETUP2- NO LINES OR PROFILE FOR RETRIEVAL GAS #',I3) RETURN END SUBROUTINE SETUP2 SUBROUTINE SETUP3( LPR, NR_LEVEL ) LOGICAL :: LPR INTEGER :: NR_LEVEL ! IF NR_LEVEL = -1 CALCULATE CROSSSECTIONS FOR ALL ALTITUDE LEVELS, ELSE ONLY FOR THE LEVEL NR_LEVEL ! --- CALCULATE VIBRATIONAL PARTITION FUNCTION FOR ALL GASES AT EACH LAYER AND AT 296K. IF( NR_LEVEL .EQ. -1 )WRITE (*, *) ' CALCULATING PARTITION FUNCTIONS...' CALL QVIB( LPR ) ! --- COMPUTE CROSS SECTIONS FOR RETRIEVAL AND BACKGROUND GASES IF( NR_LEVEL .EQ. -1 )WRITE (*, *) ' CALCULATING CROSS SECTIONS...' CALL KROSSR(NR_LEVEL) RETURN END SUBROUTINE SETUP3 !------------------------------------------------------------------------------- SUBROUTINE GETSPEC( ) INTEGER :: IBAND, JSCAN, yyyy, mo, dd, hh, mi INTEGER :: MAXPT, NREF, NPFILE, I, J, NPTSB, ISPECKODE, ISZA REAL(DOUBLE) :: R4AMP, WLIM1, WLIM2, WHI, WLOW, SMM, WAVE, TAVE, SPACE REAL(DOUBLE) :: SZA1, ROE1, LAT1, LON1, SECS CHARACTER :: TITLE*80 DATA MAXPT / MMAX / ! --- SUBROUTINE TO READ ASCII ATMOSPHERIC SPECTRAL DATA ! --- FIRST_CALL IS BY BAND - ONE SPACING FOR ALL SPECTRA IN A BAND ! --- OPEN ASCII SPECTRAL DATA WRITE (*, *) ' READING ASCII SPECTRA FILE: ', TFILE(15)(1:LEN_TRIM(TFILE(15))) CALL FILEOPEN( 15, 3 ) WRITE (6, *) ' NFIT BAND SCAN/BAND SCAN_ID SCAN_CODE SPACING RANGE' NFITS = 0 NATMOS = 0 JSCAN = 0 NSPEC = 0 NSCAN(:MAXSPE) = 0 ISCAN(:MAXBND,MAXSPE) = 0 ISPEC(:MAXSPE) = 0 ! --- LOOP OVER BANDS AND SAVE EACH FOUND SPECTRUM ! --- BANDS ARE DEFINED IN SFIT4 INPUT FILE ! --- ALL SPECTRA FOR A BAND MUST BE IN ORDER ! --- POINT SPACING FOR THE FIRST SPECTRA BLOCK IN A BAND DEFINES THE SPACING FOR THAT BAND ! --- HERE SZA1 IS ASTRONOMICAL SZA --- RAYTRACE HAS NOT BEEN RUN L3: DO IBAND = 1, NBAND 19 CONTINUE READ(15, *, END=21) SZA1, ROE1, LAT1, LON1 READ(15, *, END=21) YYYY, MO, DD, HH, MI, SECS READ(15, 888) TITLE GO TO 22 21 CONTINUE REWIND(15) CYCLE L3 22 CONTINUE READ (15, *) WLOW, WHI, SPACE, NPFILE WLIM1 = WAVE3(IBAND) WLIM2 = WAVE4(IBAND) ! -- IF NOT THIS BAND THEN DUMMY READ BLOCK AND GET NEXT IF( WLIM1>WHI .OR. WLIM2 SPACE/100000. )THEN WRITE(16,106) PRINT *,"POINT SPACING MUST BE THE SAME FOR ALL SPECTRA IN BAND" STOP ENDIF ENDIF STITLE(NFITS) = TITLE WRITE (6, 108) NFITS, IBAND, NSCAN(IBAND), ISZA, ISPEC(ISZA), SPAC(IBAND), WAVE3(IBAND), WAVE4(IBAND) IF( IBAND .EQ. NBAND )WRITE (31, 10) TITLE WRITE (6, '(4X,A76)') TITLE NPTSB = 0 SMM = 0.D0 L5: DO I = 1, NPFILE READ (15, *, END=20) R4AMP WAVE = WLOW + REAL((I - 1),8)*SPAC(IBAND) IF (WAVEWLIM2) CYCLE L5 NPTSB = NPTSB + 1 NATMOS = NATMOS + 1 IF (NATMOS > MAXPT) GO TO 40 WWV(NATMOS) = WAVE TOBS(NATMOS) = R4AMP SMM = SMM + TOBS(NATMOS) IF (NPTSB == 1) WSTART(IBAND) = WAVE WSTOP(IBAND) = WAVE ENDDO L5 20 CONTINUE IF( NPTSB .EQ. 0 )GOTO 60 ISCNDX(2,IBAND,JSCAN) = NATMOS ! --- ADJUST POINT SPACING FOR MONOCHROMATIC CALCULATIONS ! CHOOSE SPACING SO THAT SPECTRAL DATA POINT SPACING ! IS A MULTIPLE OF THE MONOCHROMATIC POINT SPACING IF( NSCAN(IBAND) .EQ. 1 )THEN WRITE(16,109) IBAND WRITE (16, 110) WAVFAC(IBAND), PMAX(IBAND), FOVDIA(IBAND), DN(IBAND), IAP(IBAND), BSNR(IBAND) NSPAC(IBAND) = FLOOR(SPAC(IBAND)/DN(IBAND) + 1.0000001D0) DN(IBAND) = SPAC(IBAND)/NSPAC(IBAND) NPRIM(IBAND) = NPTSB WRITE (16, 566) DN(IBAND), NSPAC(IBAND) ENDIF WRITE( 16,*) "" WRITE (16, 10) STITLE(NFITS) WRITE (16, 12) ISPEC(ISZA) WRITE (16, 11) WLOW, WHI, SPAC(IBAND), NPFILE WRITE (16, 102) WSTART(IBAND), WSTOP(IBAND), NPTSB, NATMOS ! --- NORMALIZE AMPLITUDES TO AVERAGE VALUE IF ABSORPTION MEASUREMENTS IF( IEMISSION .EQ. 0 .OR. IENORM(IBAND) .NE. 0) THEN TAVE = SMM/REAL(NPTSB,8) TOBS(NREF:NATMOS) = TOBS(NREF:NATMOS)/TAVE !print *, 'tave ', tave, NREF, NATMOS print *, maxval(TOBS(NREF:NATMOS)) !TOBS(NREF:NATMOS) = TOBS(NREF:NATMOS)/ maxval(TOBS(NREF:NATMOS)) END IF ! --- IF WE GET HERE WE NEED TO READ ANOTHER BLOCK IN T15ASC GOTO 19 ENDDO L3 WRITE(16,111) NSPEC, (ISPEC(I),I=1,NSPEC) ! --- ONLY USE ONE VALUE OF LATIDUTE FOR ALL RAYTRACES REF_LAT = REFLAT(1) CLOSE(15) RETURN ! --- BUFFER TRUNCATION 40 CONTINUE WRITE (16, 101) MAXPT WRITE (16, 102) WSTART(IBAND), WSTOP(IBAND), NPTSB, NATMOS CLOSE(16) CLOSE(15) STOP ! --- TOO MANY SPECTRA 50 CONTINUE WRITE(16,105) MAXSPE WRITE(6,105) MAXSPE STOP ! --- NO POINTS FOUND 60 CONTINUE WRITE (16, 103) CLOSE(6) CLOSE(15) STOP 10 FORMAT(1X,A80) 11 FORMAT( ' FIRST POINT (CM-1) = ',F12.4, /, & ' LAST POINT (CM-1) = ',F12.4, /, & ' POINT SPACING (CM-1) = ',F12.8, /, & ' NUMBER OF POINTS = ',I12) 12 FORMAT( ' SPECTRUM CODE = ',I12) 102 FORMAT( ' WSTART = ',F12.4, /, & ' WSTOP = ',F12.4, /, & ' NPRIME = ',I12, /, & ' NATMOS = ',I12) 110 FORMAT( ' WAVFAC = ',F12.7,/,& ' MAX OPD [CM-1] = ',F12.2,/,& ' FOV [MR] = ',F12.5,/,& ' REQUESTED POINT SPACING = ',F12.7,/,& ' APODIZATION CODE = ',I12,/, & ' SNR = ',F12.7) 109 FORMAT(/,' BAND = ',I12) 111 FORMAT(/,' NUMBER OF UNIQUE SPECTRA= ',I12, /,' SZA CODES:',/, 40I10) 566 FORMAT( ' MONOCHROMATIC SPACE = ',F12.8, /, & ' NSPAC = ',I12) 108 FORMAT(I5,I6,I11,I9,I11,1X,F10.7, 2X, F10.3,'-',F10.3) 101 FORMAT(' GETSPEC: ABORT-SPECTRAL DATA ARRAY SIZE LIMIT EXCEEDED-MAX =',I5) 103 FORMAT(/,/,5X,'GETSPEC: ABORT...NO POINTS'/,/) 105 FORMAT(" GETSPEC: ABORT... ATTEMPT TO READ TOO MANY SPECTRA. MAX = ",I5) 106 FORMAT(" GETSPEC: ABORT... POINT SPACING MUST BE THE SAME FOR ALL SPECTRA") 888 FORMAT(A80) RETURN END SUBROUTINE GETSPEC !------------------------------------------------------------------------------- SUBROUTINE FILSE( SED, NFIT ) ! SFIT 4 ! NO DEFAULT - INPUT ONE SNR FOR EACH BAND ! DON'T LIKE IT - SHOULD BE IN T15 ASCII FILE AS A SNR PER BAND/SPECTRUM ! --- FILLS SED VECTOR (VARIANCES OF MEASUREMENTS) ! --- USES DEFAULT S/N UNLESS A DIFFERENT VALUE IS SPECIFIED ! --- FOR A GIVEN WAVENUMBER INTERVAL ! --- MAXSNR=MAXIMUM NUMBER OF ALTERNATE S/N VALUES ! --- MMAX=MAXIMUM NUMBER OF SPECTRAL DATA POINTS INTEGER, INTENT(IN) :: NFIT !REAL(DOUBLE), INTENT(IN) :: SNR REAL(DOUBLE), INTENT(OUT) :: SED(NFIT) INTEGER :: NSTNR, I, J, K REAL(DOUBLE), DIMENSION(MMAX) :: STNR DO I = 1, NSTNR WRITE (*, *) WWV0(I), WWV1(I), GSTNR(I) END DO J = 0 10 CONTINUE J = J+1 DO I=1,NBAND IF ((WWV(J) .LT. WAVE3(I)) .OR. (WWV(J) .GT. WAVE4(I))) CYCLE IF ((.NOT. IEMISSION .NE. 0) .OR. (IENORM(I) .NE. 0)) THEN STNR(J) = 1.0D0/ABS(BSNR(I)) ELSE STNR(J) = ABS(BSNR(I)) END IF DO K = 1, NSTNR IF ((WWV(J) .LT. WWV0(K)) .OR. (WWV(J) .GT. WWV1(K))) CYCLE IF ((.NOT. IEMISSION .NE. 0) .OR.( IENORM(I) .NE. 0)) THEN STNR(J) = 1.0d0/GSTNR(K) ELSE STNR(J) = GSTNR(I) END IF END DO END DO IF (J < NFIT) GO TO 10 ! --- MEAN SNR SNR = SUM( 1.0D0/STNR(:NFIT) )/REAL(NFIT) SED = STNR(:NFIT)*STNR(:NFIT) ! ... OUTPUT_SEFILE flag set in params.inc. IF (OUTPUT_SEFILE) THEN CALL FILEOPEN( 67, 2 ) WRITE( 67, *) NFIT WRITE( 67, *) (SED(I),I=1,NFIT) CALL FILECLOSE( 67, 1 ) ENDIF RETURN END SUBROUTINE FILSE !------------------------------------------------------------------------------- SUBROUTINE RELEASE_MEM DEALLOCATE (CROSS) DEALLOCATE (CROSS_FACMAS) DEALLOCATE (TCO) DEALLOCATE (TCONV) DEALLOCATE (TCALC) DEALLOCATE (TCALC_I) DEALLOCATE (TCALC_E) DEALLOCATE (TCALC_S) DEALLOCATE (IMGG) RETURN END SUBROUTINE RELEASE_MEM END MODULE INITIALIZE