PROGRAM st_rttov_wrapper ! ! Copyright: ! This software was developed within the context of ! the EUMETSAT Satellite Application Facility on ! Numerical Weather Prediction (NWP SAF), under the ! Cooperation Agreement dated 25 November 1998, between ! EUMETSAT and the Met Office, UK, by one or more partners ! within the NWP SAF. The partners in the NWP SAF are ! the Met Office, ECMWF, KNMI and MeteoFrance. ! ! Copyright 2010, EUMETSAT, All Rights Reserved. ! ! ************************************************************* ! ! TEST PROGRAM FOR RTTOV FORWARD MODEL ! RTTOV VERSION 12 ! ! To run this program you must have the following files ! either resident in the same directory or set up as a ! symbolic link: ! the file containing input profiles (e.g. prof.dat) ! the RTTOV coefficient file ! ! The script run_example_fwd.sh may be used to run this program. ! The output is generated in a file called example_fwd_output.dat. ! ! ! To adapt the code to their own applications users should ! edit the code highlighted like this: ! !================================ ! !======Read =====start=========== ! code to be modified ! !======Read ===== end =========== ! !================================ ! ! Current Code Owner: SAF NWP ! ! Code Description: ! Language: Fortran 90. ! Software Standards: "European Standards for Writing and ! Documenting Exchangeable Fortran 90 Code". ! ************************************************************* ! Modified for JPL/ESS Group ! Developed new interface to handle binary input file ! Dr. Tanvir Islam, NASA/JPL, March 2015 (Original Coder) ! rttov_const contains useful RTTOV constants USE rttov_const, ONLY : & & errorstatus_success, & & errorstatus_fatal, & & platform_name, & & inst_name ! rttov_types contains definitions of all RTTOV data types USE rttov_types, ONLY : & & rttov_options, & & rttov_coefs, & & rttov_profile, & & rttov_transmission, & & rttov_radiance, & & rttov_radiance2, & & rttov_chanprof, & & rttov_emissivity, & & rttov_reflectance ! jpim, jprb and jplm are the RTTOV integer, real and logical KINDs USE parkind1, ONLY : jpim, jprb, jplm USE rttov_unix_env, ONLY : rttov_exit IMPLICIT NONE #include "rttov_direct.interface" #include "rttov_read_coefs.interface" #include "rttov_dealloc_coefs.interface" #include "rttov_alloc_rad.interface" #include "rttov_alloc_transmission.interface" #include "rttov_alloc_prof.interface" #include "rttov_user_options_checkinput.interface" #include "rttov_print_opts.interface" #include "rttov_print_profile.interface" #include "rttov_skipcommentline.interface" ! -------------------------- ! INTEGER(KIND=jpim), PARAMETER :: iup = 20 ! unit for input profile file INTEGER(KIND=jpim), PARAMETER :: ioout = 21 ! unit for output INTEGER(KIND=jpim), PARAMETER :: mxchn = 9000 ! max number of channels ! RTTOV variables/structures ! ========================== TYPE(rttov_options) :: opts ! Options structure TYPE(rttov_coefs) :: coefs ! Coefficients structure TYPE(rttov_chanprof), ALLOCATABLE :: chanprof(:) ! Input channel/profile list TYPE(rttov_profile), ALLOCATABLE :: profiles(:) ! Input profiles LOGICAL(KIND=jplm), ALLOCATABLE :: calcemis(:) ! Flag to indicate calculation of emissivity within RTTOV TYPE(rttov_emissivity), ALLOCATABLE :: emissivity(:) ! Input/output surface emissivity LOGICAL(KIND=jplm), ALLOCATABLE :: calcrefl(:) ! Flag to indicate calculation of BRDF within RTTOV TYPE(rttov_reflectance), ALLOCATABLE :: reflectance(:) ! Input/output surface BRDF TYPE(rttov_transmission) :: transmission ! Output transmittances TYPE(rttov_radiance) :: radiance ! Output radiances TYPE(rttov_radiance2) :: radiance2 ! Output radiances INTEGER(KIND=jpim) :: errorstatus ! Return error status of RTTOV subroutine calls INTEGER(KIND=jpim) :: alloc_status(10) CHARACTER(LEN=11) :: NameOfRoutine = 'example_fwd' ! variables for input ! ==================== INTEGER(KIND=jpim) :: input_chan(mxchn) REAL(KIND=jprb) :: input_ems(mxchn), input_brdf(mxchn) CHARACTER(LEN=256) :: coef_filename CHARACTER(LEN=256) :: prof_filename INTEGER(KIND=jpim) :: dosolar INTEGER(KIND=jpim) :: nlevels INTEGER(KIND=jpim) :: nprof INTEGER(KIND=jpim) :: nchannels INTEGER(KIND=jpim) :: nchanprof INTEGER(KIND=jpim) :: ivch, ich REAL(KIND=jprb) :: ems_val, brdf_val INTEGER(KIND=jpim) :: asw REAL(KIND=jprb), ALLOCATABLE :: emis(:), brdf(:) INTEGER(KIND=jpim), ALLOCATABLE :: nchan(:) REAL(KIND=jprb) :: trans_out(10) ! loop variables INTEGER(KIND=jpim) :: j, jch INTEGER(KIND=jpim) :: np, nch INTEGER(KIND=jpim) :: ilev, nprint INTEGER(KIND=jpim) :: iprof, joff INTEGER :: ios ! binary input varibles REAL :: nrec REAL :: nlev REAL, DIMENSION(:), ALLOCATABLE :: Psurf,Tsurf,Qsurf,Tskin,ST,Hsurf,SatZen,Lat_rad,Lon_rad REAL, DIMENSION(:,:), ALLOCATABLE :: P,T,Q,Bemis INTEGER :: ftype ! 0=binary, 1=ascii ! - End of header -------------------------------------------------------- ! The usual steps to take when running RTTOV are as follows: ! 1. Specify required RTTOV options ! 2. Read coefficients ! 3. Set up the chanprof array with the channels/profiles to simulate ! 4. Allocate RTTOV profile, radiance and transmittance structures ! 5. Read input profile(s) ! 6. Set up surface emissivity and/or reflectance ! 7. Call rttov_direct and store results ! 8. Deallocate all structures and arrays errorstatus = 0_jpim alloc_status(:) = 0_jpim ! ===================================================== ! ==========Interactive inputs == start ============== WRITE(0,*) 'enter name of coefficient file (in current directory)' READ(*,*) coef_filename WRITE(0,*) 'enter name of file containing profile data (in current directory)' READ(*,*) prof_filename WRITE(0,*) 'enter number of profiles' READ(*,*) nprof WRITE(0,*) 'enter number of profile levels' READ(*,*) nlevels WRITE(0,*) 'turn on solar simulations? (0=no, 1=yes)' READ(*,*) dosolar WRITE(0,*) 'binary or ascii? (0=binary, 1=ascii)' READ(*,*) ftype ! Read channel list including input surface emissivities and reflectances ! If the input emissivities/reflectances are zero or less, calcemis/calcrefl is set to true. nchannels = 0_jpim WRITE(*,*) 'about to read first channel nchannels=', nchannels ! RRRR TMP READ(*,*,iostat=ios) ich, ivch, ems_val, brdf_val ! channel number, validity, emissivity, reflectance WRITE(*,*) 'done first channel read' ! RRRR TMP WRITE(*,*) 'ios =', ios WRITE(*,*) 'ich =', ich WRITE(*,*) 'ivch =', ivch WRITE(*,*) 'ems_val =', ems_val WRITE(*,*) 'brdf_val =', brdf_val DO WHILE (ios == 0 ) IF (ivch /= 0) THEN nchannels = nchannels + 1_jpim input_chan(nchannels) = ich input_ems(nchannels) = ems_val input_brdf(nchannels) = brdf_val ENDIF READ(*,*,iostat=ios) ich, ivch, ems_val, brdf_val WRITE(*,*) '2ios =', ios WRITE(*,*) '2ich =', ich WRITE(*,*) '2ivch =', ivch WRITE(*,*) '2ems_val =', ems_val WRITE(*,*) '2brdf_val =', brdf_val WRITE(*,*) 'done next channel read nchannels=', nchannels ! RRRR TMP ENDDO WRITE(*,*) 'done reading channels' ! RRRR TMP WRITE(*,*) 'nchannels', nchannels ! RRRR TMP WRITE(*,*) 'input_chan(1)', input_chan(1) ! RRRR TMP WRITE(*,*) 'input_ems(1)', input_ems(1) ! RRRR TMP WRITE(*,*) 'input_brdf()', input_brdf(1) ! RRRR TMP IF (nchannels == 2) THEN ! RRRR TMP WRITE(*,*) 'input_chan(2)', input_chan(2) ! RRRR TMP WRITE(*,*) 'input_ems(2)', input_ems(2) ! RRRR TMP WRITE(*,*) 'input_brdf(2)', input_brdf(2) ! RRRR TMP ENDIF ! RRRR TMP ! -------------------------------------------------------------------------- ! 1. Initialise RTTOV options structure ! -------------------------------------------------------------------------- IF (dosolar == 1) THEN opts % rt_ir % addsolar = .TRUE. ! Include solar radiation ELSE opts % rt_ir % addsolar = .FALSE. ! Do not include solar radiation ENDIF opts % interpolation % addinterp = .TRUE. ! Allow interpolation of input profile opts % interpolation % interp_mode = 1 ! Set interpolation method opts % config % apply_reg_limits = .TRUE. ! Apply regression limit opts % rt_all % addrefrac = .TRUE. ! Include refraction in path calc opts % rt_ir % addclouds = .FALSE. ! Don't include cloud effects opts % rt_ir % addaerosl = .FALSE. ! Don't include aerosol effects opts % rt_all % ozone_data = .FALSE. ! We have an ozone profile opts % rt_all % co2_data = .FALSE. ! We do not have profiles opts % rt_all % n2o_data = .FALSE. ! for any other constituents opts % rt_all % ch4_data = .FALSE. ! opts % rt_all % co_data = .FALSE. ! opts % rt_mw % clw_data = .FALSE. ! ! ==========Interactive inputs == end ============== ! =================================================== ! -------------------------------------------------------------------------- ! 2. Read coefficients ! -------------------------------------------------------------------------- CALL rttov_read_coefs(errorstatus, coefs, opts, file_coef=coef_filename) IF (errorstatus /= errorstatus_success) THEN WRITE(*,*) 'fatal error reading coefficients' CALL rttov_exit(errorstatus) ENDIF ! Ensure input number of channels is not higher than number stored in coefficient file IF (nchannels > coefs % coef % fmv_chn) THEN nchannels = coefs % coef % fmv_chn ENDIF ! Ensure the options and coefficients are consistent CALL rttov_user_options_checkinput(errorstatus, opts, coefs) IF (errorstatus /= errorstatus_success) THEN WRITE(*,*) 'error in rttov options' CALL rttov_exit(errorstatus) ENDIF ! -------------------------------------------------------------------------- ! 2.1. Read binary profile files ! -------------------------------------------------------------------------- IF (ftype .eq. 0) THEN open(11, file=TRIM(prof_filename), form = 'unformatted', & access='stream') read(11) nrec read (11) nlev ALLOCATE (Psurf(INT(nrec)),Tsurf(INT(nrec)),Qsurf(INT(nrec)), & Tskin(INT(nrec)), ST(INT(nrec)), Hsurf(INT(nrec)), SatZen(INT(nrec)),& Lat_rad(INT(nrec)), Lon_rad(INT(nrec))) ALLOCATE (P(INT(nrec),INT(nlev)),T(INT(nrec),INT(nlev)),Q(INT(nrec),INT(nlev)),Bemis(INT(nrec),INT(nchannels))) read (11) P write(*,*) 'P=', P read (11) T write(*,*) 'T=', T read (11) Q write(*,*) 'Q=', Q read (11) Psurf write(*,*) 'Psurf =', Psurf read (11) Tsurf write(*,*) 'Tsurf =', Tsurf read (11) Qsurf write(*,*) 'Qsurf =', Qsurf read (11) Tskin write(*,*) 'Tskin =', Tskin read (11) ST write(*,*) 'ST =', ST read (11) Hsurf write(*,*) 'Hsurf =', Hsurf read (11) SatZen write(*,*) 'SatZen =', SatZen read (11) Lat_rad write(*,*) 'Lat_rad =', Lat_rad read (11) Lon_rad write(*,*) 'Lon_rad =', Lon_rad read (11) Bemis write(*,*) 'Bemis =', Bemis close(11) ! nprof/nlevel transfer nprof = nrec nlevels = nlev write(*,*) 'nprof/nlevels =', nprof, nlevels ENDIF ! -------------------------------------------------------------------------- ! 3. Build the list of profile/channel indices in chanprof ! -------------------------------------------------------------------------- ! In general the number of channels simulated per profile can vary, but for ! this example we simulate all specified channels for each profile. ALLOCATE(nchan(nprof)) ! Number of channels per profile nchan(:) = nchannels nchanprof = SUM(nchan(:)) ! Size of chanprof array is total number of channels over all profiles ! Pack channels and input emissivity arrays ALLOCATE(chanprof(nchanprof)) ALLOCATE(emis(nchanprof)) ALLOCATE(brdf(nchanprof)) nch = 0_jpim DO j = 1, nprof DO jch = 1, nchan(j) nch = nch + 1_jpim chanprof(nch)%prof = j chanprof(nch)%chan = input_chan(jch) emis(nch) = Bemis(j,jch) brdf(nch) = input_brdf(jch) ENDDO ENDDO ! -------------------------------------------------------------------------- ! 4. Allocate profiles, radiance and transmittance structures ! -------------------------------------------------------------------------- asw = 1 ! Switch for allocation passed into RTTOV subroutines ! Allocate input profile arrays ALLOCATE(profiles(nprof), stat=alloc_status(1)) IF (ANY(alloc_status /= 0)) THEN WRITE(*,*) 'mem allocation error for profile array' CALL rttov_exit(errorstatus_fatal) ENDIF CALL rttov_alloc_prof( & & errorstatus, & & nprof, & & profiles, & & nlevels, & & opts, & & asw, & & coefs=coefs, & & init=.TRUE._jplm ) IF (errorstatus /= errorstatus_success) THEN WRITE(*,*) 'allocation error for profile arrays' CALL rttov_exit(errorstatus) ENDIF ! Allocate output radiance arrays CALL rttov_alloc_rad( & & errorstatus, & & nchanprof, & & radiance, & & nlevels-1_jpim, & & asw, & & radiance2) IF (errorstatus /= errorstatus_success) THEN WRITE(*,*) 'allocation error for radiance arrays' CALL rttov_exit(errorstatus) ENDIF ! Allocate transmittance structure CALL rttov_alloc_transmission( & & errorstatus, & & transmission, & & nlevels-1_jpim, & & nchanprof, & & asw, & & init=.TRUE._jplm) IF (errorstatus /= errorstatus_success) THEN WRITE(*,*) 'allocation error for transmission arrays' CALL rttov_exit(errorstatus) ENDIF ! Allocate arrays for surface emissivity ALLOCATE(calcemis(nchanprof), stat=alloc_status(1)) ALLOCATE(emissivity(nchanprof), stat=alloc_status(2)) IF (ANY(alloc_status /= 0)) THEN WRITE(*,*) 'mem allocation error for emissivity arrays' CALL rttov_exit(errorstatus_fatal) ENDIF ! Allocate arrays for surface reflectance ALLOCATE(calcrefl(nchanprof), stat=alloc_status(1)) ALLOCATE(reflectance(nchanprof), stat=alloc_status(2)) IF (ANY(alloc_status /= 0)) THEN WRITE(*,*) 'memallocation error for reflectance arrays' CALL rttov_exit(errorstatus_fatal) ENDIF ! -------------------------------------------------------------------------- ! 5. Read profile data ! -------------------------------------------------------------------------- ! =============================================== ! ==========READ profiles == start ============= ! ----Binary---- IF (ftype .eq. 0) THEN ! Loop over all profiles and read data for each one DO iprof = 1,INT(nrec) ! Set gas units profiles(iprof) % gas_units = 2 ! READ pressure (hPa), temp (K), WV (ppmv), O3 (ppmv) profiles(iprof) % p(:) = P(iprof,:) profiles(iprof) % t(:) = T(iprof,:) profiles(iprof) % q(:) = Q(iprof,:) ! 2 meter air variables profiles(iprof) % s2m % t = Tsurf(iprof) profiles(iprof) % s2m % q = Qsurf(iprof) profiles(iprof) % s2m % p = Psurf(iprof) profiles(iprof) % s2m % u = 5.0 profiles(iprof) % s2m % v = 2.0 profiles(iprof) % s2m % wfetc = 100000.0 ! Skin variables profiles(iprof) % skin % t = Tskin(iprof) ! profiles(iprof) % skin % fastem = 0.0 ! FASTEM only applies to MW instruments ! Surface type and water type profiles(iprof) % skin % surftype = ST(iprof) profiles(iprof) % skin % watertype = 0 ! Elevation, latitude and longitude profiles(iprof) % elevation = Hsurf(iprof) profiles(iprof) % latitude = Lat_rad(iprof) profiles(iprof) % longitude = Lon_rad(iprof) ! Satellite and solar angles profiles(iprof) % zenangle = abs(SatZen(iprof)) ! profiles(iprof) % azangle = 0.0 ! Applies only in solar option ! profiles(iprof) % sunzenangle = 0.0 ! profiles(iprof) % sunazangle = 0.0 ! Cloud variables for simple cloud scheme (set cfraction to 0. to turn this off) profiles(iprof) % ctp = 500.0 profiles(iprof) % cfraction = 0.0 ENDDO ! Deallocate binary input file variables DEALLOCATE (Psurf,Tsurf,Qsurf, Tskin, ST, Hsurf, SatZen,Lat_rad, Lon_rad) DEALLOCATE (P,T,Q,BEmis) ! --- Ascii --- ELSEIF (ftype .eq. 1) THEN OPEN(iup, file=TRIM(prof_filename), status='old', iostat=ios) IF (ios /= 0) THEN WRITE(*,*) 'error opening profile file ios= ', ios CALL rttov_exit(errorstatus_fatal) ENDIF CALL rttov_skipcommentline(iup, errorstatus) ! Loop over all profiles and read data for each one DO iprof = 1, nprof ! READ pressure (hPa), temp (K), WV (ppmv), O3 (ppmv) READ(iup,*) profiles(iprof) % p(:) CALL rttov_skipcommentline(iup, errorstatus) READ(iup,*) profiles(iprof) % t(:) CALL rttov_skipcommentline(iup, errorstatus) READ(iup,*) profiles(iprof) % q(:) CALL rttov_skipcommentline(iup, errorstatus) READ(iup,*) profiles(iprof) % o3(:) CALL rttov_skipcommentline(iup, errorstatus) ! 2 meter air variables READ(iup,*) profiles(iprof) % s2m % t, & & profiles(iprof) % s2m % q, & & profiles(iprof) % s2m % p, & & profiles(iprof) % s2m % u, & & profiles(iprof) % s2m % v, & & profiles(iprof) % s2m % wfetc CALL rttov_skipcommentline(iup, errorstatus) ! Skin variables READ(iup,*) profiles(iprof) % skin % t, & & profiles(iprof) % skin % fastem !FASTEM only applies to MW instruments CALL rttov_skipcommentline(iup, errorstatus) ! Surface type and water type READ(iup,*) profiles(iprof) % skin % surftype, & & profiles(iprof) % skin % watertype CALL rttov_skipcommentline(iup, errorstatus) ! Elevation, latitude and longitude READ(iup,*) profiles(iprof) % elevation, & & profiles(iprof) % latitude, & & profiles(iprof) % longitude CALL rttov_skipcommentline(iup, errorstatus) ! Satellite and solar angles READ(iup,*) profiles(iprof) % zenangle, & & profiles(iprof) % azangle, & & profiles(iprof) % sunzenangle, & & profiles(iprof) % sunazangle CALL rttov_skipcommentline(iup, errorstatus) ! Cloud variables for simple cloud scheme (set cfraction to 0. to turn this off) READ(iup,*) profiles(iprof) % ctp, & & profiles(iprof) % cfraction CALL rttov_skipcommentline(iup, errorstatus) ENDDO CLOSE(iup) ENDIF ! ==========READ profiles == end ============= ! ============================================= ! -------------------------------------------------------------------------- ! 6. Specify surface emissivity and reflectance ! -------------------------------------------------------------------------- ! Copy emissivities into RTTOV input emissivity array emissivity(:) % emis_in = emis(:) ! Calculate emissivity within RTTOV where the input emissivity value is ! zero or less calcemis(:) = emis(:) <= 0._jprb ! Copy BRDFs into RTTOV input reflectance array reflectance(:) % refl_in = brdf(:) ! Calculate BRDF within RTTOV where the input BRDF value is zero or less calcrefl(:) = brdf(:) <= 0._jprb ! Use default cloud top BRDF for simple cloud in VIS/NIR channels reflectance(:) % refl_cloud_top = 0._jprb ! -------------------------------------------------------------------------- ! 7. Call RTTOV forward model ! -------------------------------------------------------------------------- CALL rttov_direct( & & errorstatus, & ! out error flag & chanprof, & ! in channel and profile index structure & opts, & ! in options structure & profiles, & ! in profile array & coefs, & ! in coefficients strucutre & transmission, & ! inout computed transmittances & radiance, & ! inout computed radiances & radiance2, & ! inout computed radiances 2 & calcemis = calcemis, & ! in flag for internal emissivity calcs & emissivity = emissivity, & ! inout input/output emissivities per channel & calcrefl = calcrefl, & ! in flag for internal BRDF calcs & reflectance = reflectance) ! inout input/output BRDFs per channel IF (errorstatus /= errorstatus_success) THEN WRITE (*,*) 'rttov_direct error' CALL rttov_exit(errorstatus) ENDIF ! --- Output the results -------------------------------------------------- ! --- Binary--- IF (ftype .eq. 0) THEN ! Open output file where results are written OPEN(ioout, file='rad_out.dat', status='unknown', form='formatted', iostat=ios) DO iprof = 1, INT(nrec) joff = (iprof-1_jpim) * nchannels ! 'UPWELLING RADIANCES WITHOUT REFL TERM (CLEAR)' ! 'REFLECTED DOWNWELLING RADIANCES (CLEAR)' ! 'SURFACE TO SPACE TRANSMITTANCE:' WRITE(ioout,*) (radiance2 % upclear(j), j = 1+joff, nchannels+joff), & (radiance2 % refldnclear(j), j = 1+joff, nchannels+joff), & (transmission % tau_total(j), j = 1+joff, nchannels+joff) ENDDO ! --- Ascii--- ELSEIF (ftype .eq. 1) THEN ! Open output file where results are written OPEN(ioout, file='output_'//NameOfRoutine//'.dat', status='unknown', form='formatted', iostat=ios) IF (ios /= 0) THEN WRITE(*,*) 'error opening the output file ios= ', ios CALL rttov_exit(errorstatus_fatal) ENDIF WRITE(ioout,*)' -----------------' WRITE(ioout,*)' Instrument ', inst_name(coefs % coef % id_inst) WRITE(ioout,*)' -----------------' WRITE(ioout,*)' ' CALL rttov_print_opts(opts, lu=ioout) DO iprof = 1, nprof joff = (iprof-1_jpim) * nchannels nprint = 1 + INT((nchannels-1)/10) WRITE(ioout,*)' ' WRITE(ioout,*)' Profile ', iprof CALL rttov_print_profile(profiles(iprof), lu=ioout) WRITE(ioout,777)'CHANNELS PROCESSED FOR SAT ', platform_name(coefs % coef % id_platform), coefs % coef % id_sat WRITE(ioout,111) (chanprof(j) % chan, j = 1+joff, nchannels+joff) WRITE(ioout,*)' ' WRITE(ioout,*)'CALCULATED BRIGHTNESS TEMPERATURES (K):' WRITE(ioout,222) (radiance % bt(j), j = 1+joff, nchannels+joff) IF (opts % rt_ir % addsolar) THEN WRITE(ioout,*)' ' WRITE(ioout,*)'CALCULATED SATELLITE REFLECTANCES (BRF):' WRITE(ioout,444) (radiance % refl(j), j = 1+joff, nchannels+joff) ENDIF WRITE(ioout,*)' ' WRITE(ioout,*)'CALCULATED RADIANCES (mW/m2/sr/cm-1):' WRITE(ioout,222) (radiance % total(j), j = 1+joff, nchannels+joff) WRITE(ioout,*)' ' WRITE(ioout,*)'CALCULATED OVERCAST RADIANCES:' WRITE(ioout,222) (radiance % cloudy(j), j = 1+joff, nchannels+joff) WRITE(ioout,*)' ' WRITE(ioout,*)'CALCULATED SURFACE TO SPACE TRANSMITTANCE:' WRITE(ioout,4444) (transmission % tau_total(j), j = 1+joff, nchannels+joff) WRITE(ioout,*)' ' WRITE(ioout,*)'CALCULATED SURFACE EMISSIVITIES:' WRITE(ioout,444) (emissivity(j) % emis_out, j = 1+joff, nchannels+joff) IF (opts % rt_ir % addsolar) THEN WRITE(ioout,*)' ' WRITE(ioout,*)'CALCULATED SURFACE BRDF:' WRITE(ioout,444) (reflectance(j) % refl_out, j = 1+joff, nchannels+joff) ENDIF IF (nchan(nprof) <= 20) THEN DO np = 1, nprint WRITE(ioout,*)' ' WRITE(ioout,*)'Level to space transmittances for channels' WRITE(ioout,1115) (chanprof(j+joff) % chan, & & j = 1+(np-1)*10, MIN(np*10, nchannels)) DO ilev = 1, nlevels DO j = 1 + (np-1)*10, MIN(np*10, nchannels) ! Select transmittance based on channel type (VIS/NIR or IR) IF (coefs % coef % ss_val_chn(chanprof(j+joff) % chan) == 2) THEN trans_out(j - (np-1)*10) = transmission % tausun_levels_path1(ilev,j+joff) ELSE trans_out(j - (np-1)*10) = transmission % tau_levels(ilev,j+joff) ENDIF ENDDO WRITE(ioout,4445) ilev, trans_out(1:j-1-(np-1)*10) ENDDO WRITE(ioout,1115) (chanprof(j+joff) % chan, & & j = 1+(np-1)*10, MIN(np*10, nchannels)) ENDDO ENDIF ENDDO ENDIF ! Close output file CLOSE(ioout, iostat=ios) IF (ios /= 0) THEN WRITE(*,*) 'error closing the output file ios= ', ios CALL rttov_exit(errorstatus_fatal) ENDIF ! --- End of output section ----------------------------------------------- ! -------------------------------------------------------------------------- ! 8. Deallocate all RTTOV arrays and structures ! -------------------------------------------------------------------------- DEALLOCATE (emis, stat=alloc_status(1)) DEALLOCATE (brdf, stat=alloc_status(2)) DEALLOCATE (nchan, stat=alloc_status(3)) DEALLOCATE (chanprof, stat=alloc_status(4)) DEALLOCATE (emissivity, stat=alloc_status(5)) DEALLOCATE (calcemis, stat=alloc_status(6)) DEALLOCATE (reflectance, stat=alloc_status(7)) DEALLOCATE (calcrefl, stat=alloc_status(8)) IF (ANY(alloc_status /= 0)) THEN WRITE(*,*) 'mem dellocation error' ENDIF asw = 0 ! Switch for deallocation passed into RTTOV subroutines ! Deallocate radiance arrays CALL rttov_alloc_rad(errorstatus, nchanprof, radiance, nlevels-1_jpim, asw) IF(errorstatus /= errorstatus_success) THEN WRITE(*,*) 'radiance deallocation error' ENDIF ! Deallocate transmission arrays !CALL rttov_alloc_transmission(errorstatus, transmission, nlevels-1_jpim, nchanprof, asw) !IF (errorstatus /= errorstatus_success) THEN ! WRITE(*,*) 'transmission deallocation error' !ENDIF ! Deallocate profile arrays CALL rttov_alloc_prof(errorstatus, nprof, profiles, nlevels, opts, asw) IF (errorstatus /= errorstatus_success .or. alloc_status(1) /= 0) THEN WRITE(*,*) 'profile deallocation error' ENDIF DEALLOCATE(profiles, stat=alloc_status(1)) IF (alloc_status(1) /= 0) THEN WRITE(*,*) 'mem deallocation error for profile array' ENDIF CALL rttov_dealloc_coefs(errorstatus, coefs) IF (errorstatus /= errorstatus_success) THEN WRITE(*,*) 'coefs deallocation error' ENDIF ! Format definitions for output 111 FORMAT(1X,10I8) 1115 FORMAT(3X,10I8) 222 FORMAT(1X,10F8.2) 444 FORMAT(1X,10F8.3) 4444 FORMAT(1X,10F8.4) 4445 FORMAT(1X,I2,10F8.4) 777 FORMAT(/,A,A8,I3) END PROGRAM st_rttov_wrapper