PROGRAM RADIANT2S_DRIVER_PROGRAM !THIS PROGRAM SERVES AS A DRIVER PROGRAM FOR RADIANT 2.0 !PROGRAMMER: MATT CHRISTI !DATE LAST MODIFIED: 8/09/04 !DATA DICTIONARY**************************************************************** ! ! ALBEDO = SURFACE ALBEDO WHEN SURF=1 ! B_IO = SUBROUTINE BUILD_LAYER I/O FLAG ! (0=OFF, 1=ON) ! CHI_AERO = MATRIX CONTAINING COEFFICIENTS FOR LEGENDRE POLYNOMIAL ! EXPANSION OF AEROSOL PHASE FUNCTION FOR ANY LAYER (IF USED) ! CHI_CLD = MATRIX CONTAINING COEFFICIENTS FOR LEGENDRE POLYNOMIAL ! EXPANSION OF CLOUD PHASE FUNCTION FOR ANY LAYER (IF USED) ! CHI_SURF = VECTOR CONTAINING COEFFICIENTS FOR LEGENDRE POLYNOMIAL ! EXPANSION OF SURFACE BIDIRECTIONAL REFLECTIVITY (IF USED) ! DELTA_M_AERO = VECTOR OF FLAGS TO INDICATE WHETHER OR NOT DELTA_M SCALING IS ! USED IN SUBROUTINE LOCAL FOR POSSIBLE AEROSOL PHASE FUNCTION ! IN EACH LAYER ! (0=NO, 1=YES) ! DELTA_M_CLD = VECTOR OF FLAGS TO INDICATE WHETHER OR NOT DELTA_M SCALING IS ! USED IN SUBROUTINE LOCAL FOR POSSIBLE CLOUD PHASE FUNCTION ! IN EACH LAYER ! (0=NO, 1=YES) ! DELTAZ = VECTOR CONTAINING THICKNESSES OF LAYERS UNDER COMPUTATION ! (IN km) ! DG = FLAG TO INDICATE WHICH VERSION OF GAUSS QUADRATURE WILL BE ! USED IN SUBROUTINE LOCAL IF QUAD = 0 IS SELECTED ! (0=NORMAL GAUSS, 1=DOUBLE GAUSS) ! DISPLAY_IN = I/O FLAG TO PERMIT DISPLAY OF USER INPUT TO SCREEN ! (0=OFF, 1=ON) ! DISPLAY_OUT = I/O FLAG TO PERMIT DISPLAY OF RADIANCE OUTPUT TO SCREEN ! (0=OFF, 1=ON) ! EPS = AMOUNT BY WHICH OPTICAL PROPERTIES ARE PERTURBED BY FOR THE ! COMPUTATION OF JACOBIAN ELEMENTS BY FINITE DIFFERENCE WHEN ! THE PERTURBATION SCHEME IS IN USE ! FIB = FLUX INTO THE BOTTOM BOUNDARY ! FIT = FLUX INTO THE TOP BOUNDARY ! FLUX_IO = FLUX TEST I/O FLAG FOR SUBROUTINE RAD ! (0=OFF, 1=ON) ! FLUXES = RADIANT FLUX OUTPUT I/O FLAG ! (0=OFF, 1=ON) ! FOB = FLUX OUT OF THE BOTTOM BOUNDARY ! FOT = FLUX OUT OF THE TOP BOUNDARY ! FSUN = FLUX AT THE TOP OF THE ATMOSPHERE AT A GIVEN WAVELENGTH ! G_AERO = VECTOR OF AEROSOL EFFECTIVE ASYMMETRY PARAMETERS ! G1_AERO = VECTOR OF AEROSOL ASYMMETRY PARAMETERS FOR FORWARD SCATTERING ! G2_AERO = VECTOR OF AEROSOL ASYMMETRY PARAMETERS FOR BACKWARD SCATTERING ! G_CLD = VECTOR OF CLOUD EFFECTIVE ASYMMETRY PARAMETERS ! G1_CLD = VECTOR OF CLOUD ASYMMETRY PARAMETERS FOR FORWARD SCATTERING ! G2_CLD = VECTOR OF CLOUD ASYMMETRY PARAMETERS FOR BACKWARD SCATTERING ! INV_IO = SUBROUTINE INVERT I/O FLAG (FOR MATRIX INVERSE) ! (0=OFF, 1=ON) ! IBMTOT = VECTOR OF TOTAL DOWNWELLING RADIANCES AT THE BOTTOM OF THE ! ATMOSPHERE FROM ALL FOURIER COMPONENTS COMPUTED ! IBPTOT = VECTOR OF TOTAL UPWELLING RADIANCE AT THE BOTTOM OF THE ! ATMOSPHERE FROM ALL FOURIER COMPONENTS COMPUTED ! ITM = VECTOR OF TOTAL DOWNWELLING DIFFUSE RADIANCES FROM THE TOP ! BOUNDARY ! ITMS = VECTOR OF DOWNWELLING DIFFUSE SOLAR RADIANCES FROM THE TOP ! BOUNDARY ! ITMT = VECTOR OF DOWNWELLING DIFFUSE THERMAL RADIANCES FROM THE TOP ! BOUNDARY ! ITPTOT = VECTOR OF TOTAL UPWELLING RADIANCES AT THE TOP BOUNDARY ! FROM ALL FOURIER COMPONENTS COMPUTED ! KFLAG = FLAG TO INDICATE WHETHER OR NOT ADDITIONAL COMPUTATIONS WILL ! BE PERFORMED INSIDE RADIANT TO PREPARE FOR SUBSEQUENT CALLS ! TO RADIANT WHERE SAVED MATRICES WILL BE USED ! (0=NO, 1=YES) ! NOTE: KFLAG USED IN CONJUNCTION WITH WVN_FLAG ! L_IO = SUBROUTINE LOCAL I/O FLAG ! (0=OFF, 1=ON) ! LAYCHG = LAYER NUMBER OF CHANGED LAYER WHEN IN LAYER-SAVING MODE ! NUMLAY = NUMBER OF LAYERS IN THE MODEL ATMOSPHERE ! OMEGA_AERO = VECTOR OF SINGLE SCATTER ALBEDO FOR AEROSOL ! OMEGA_CLD = VECTOR OF SINGLE SCATTER ALBEDO FOR CLOUD ! P_IO = SUBROUTINE RADIANT I/O FLAG ! (0=OFF, 1=ON) ! PERT_FLAG = FLAG TO INDICATE WHETHER OR NOT THE PERTURBATION SCHEME WILL ! BE USED TO BUILD LAYERS ON SUBSEQUENT CALLS TO RADIANT DURING ! LAYER SAVING MODE ! (0=NO, 1=YES) ! PF_AERO = VECTOR OF FLAGS TO DETERMINE HOW COEFFICIENTS OF AEROSOL PHASE ! FUNCTION EXPANSION ARE OBTAINED ! (1=HENYEY-GREENSTEIN - SINGLE OR DOUBLE DEPENDING ON INPUT, ! 2=DETERMINED BY CHI_AERO) ! PF_CLD = VECTOR OF FLAGS TO DETERMINE HOW COEFFICIENTS OF CLOUD PHASE ! FUNCTION EXPANSION ARE OBTAINED ! (1=HENYEY-GREENSTEIN - SINGLE OR DOUBLE DEPENDING ON INPUT, ! 2=DETERMINED BY CHI_CLD) ! PHI = AZIMUTH ANGLE FOR WHICH THE RADIANCE VECTOR IS COMPUTED ! (in degrees) ! NOTE: REFERENCE AZIMUTH ASSUMED TO BE 0 ! PLANCK_FLAG = FLAG TO CHOOSE WHETHER SPECTRAL RADIANCES OR RADIANCES WILL ! BE USED FOR THERMAL SOURCES ! (0=SPECTRAL RADIANCES (in mW/(m^2 cm^-1 ster)) ! 1=RADIANCES (in mW/(m^2 ster)) ) ! QUAD = FLAG TO INDICATE WHICH QUADRATURE SCHEME WILL BE USED ! (0=GAUSS, 1=LOBATTO) ! R_IO = SUBROUTINE RAD I/O FLAG ! (0=OFF, 1=ON) ! SRC_FLAG = FLAG INDICATING TYPE OF SOURCES INCLUDED IN COMPUTING ! RADIANCES ! (1=SOLAR ONLY, 2=SOLAR & THERMAL, 3=THERMAL ONLY) ! STREAMS = NUMBER OF STREAMS TO COMPUTE RADIANCE FIELD ! SURF = FLAG INDICATING TYPE OF REFLECTING SURFACE ! (0=NONE, 1=LAMBERTIAN, 2=DETERMINED BY CHI_SURF) ! SZA = THE SOLAR ZENITH ANGLE (in degrees from zenith) ! TAU_AERO = VECTOR OF OPTICAL DEPTHS FOR AEROSOL ! TAU_CLD = VECTOR OF OPTICAL DEPTHS FOR CLOUD ! TAU_GAS = VECTOR OF OPTICAL DEPTHS FOR ATMOSPHERIC GAS ! TAU_RAY = VECTOR OF OPTICAL DEPTHS FOR RAYLEIGH SCATTERING ! TEMISS = EMISSIVITY OF TOP BOUNDARY FOR THERMAL SOURCES ! TLEV = VECTOR (I.E. VERTICAL PROFILE) OF LEVEL-BASED ATMOSPHERIC ! TEMPERATURES (in K) ! TSURF = TEMPERATURE OF THE SURFACE (in K) ! TTOP = TEMPERATURE OF THE TOP BOUNDARY (in K) ! VIEW_ANGLE = THE USER-DEFINED VIEW ANGLE (in degrees from zenith) ! VIEW_FLAG = FLAG INDICATING USER-DEFINED VIEW ANGLE IN USE ! (0=OFF, 1=ON) ! WVN = WAVENUMBER FOR WHICH SPECTRAL RADIANCE IS COMPUTED FOR PLANCK ! FUNCTION (in cm^-1) ! WVNLO = LOW WAVENUMBER IN SPECTRAL INTERVAL FOR WHICH RADIANCE IS ! COMPUTED FROM INTEGRAL OF PLANCK FUNCTION (in cm^-1) ! WVNHI = HIGH WAVENUMBER IN SPECTRAL INTERVAL FOR WHICH RADIANCE IS ! COMPUTED FROM INTEGRAL OF PLANCK FUNCTION (in cm^-1) ! WVN_FLAG = FLAG TO INDICATE WHETHER OR NOT SAVED MATRICES WILL BE ! USED TO COMPUTE RADIANCES ON CURRENT CALL TO SUBROUTINE ! RADIANT ! ('NEW'=NO, 'OLD'=YES) ! NOTE: WVN_FLAG USED IN CONJUNCTION WITH KFLAG ! WARNING_FLAG = RADIANT WARNING MESSAGES I/0 FLAG ! (0=OFF, 1=ON) ! !******************************************************************************* USE RADIANT2S IMPLICIT NONE !INPUT VARIABLES (DRIVER) INTEGER :: & DISPLAY_IN,DISPLAY_OUT,STREAMS !INPUT VARIABLES (RADIANT) INTEGER :: & B_IO,DG,FLUX_IO,FLUXES,INV_IO,KFLAG,L_IO,N,& NUMLAY,P_IO,PERT_FLAG,PLANCK_FLAG,QUAD,R_IO,SRC_FLAG,SURF,& VIEW_FLAG,WARNING_FLAG,LAYCHG INTEGER, DIMENSION(:), ALLOCATABLE :: & DELTA_M_AERO,DELTA_M_CLD,PF_AERO,PF_CLD DOUBLE PRECISION :: & ALBEDO,EPS,FSUN,FOURIER_TOL,PHI,TEMISS,SZA,TSURF,TTOP,& VIEW_ANGLE,WVN,WVNLO,WVNHI DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: & G_AERO,G_CLD,G1_AERO,G1_CLD,G2_AERO,G2_CLD,SZA_IN,TSURF_IN,VIEW_ANGLE_IN,& ITMS,ITMT,OMEGA_AERO,OMEGA_CLD,TAU_AERO,TAU_CLD,TAU_GAS,& TAU_RAY,TLEV,CHI_SURF DOUBLE PRECISION, DIMENSION(:,:), ALLOCATABLE :: & CHI_AERO,CHI_CLD CHARACTER(LEN=3) :: & WVN_FLAG LOGICAL :: & AZIMUTHAL_RAD_ONLY !OUTPUT VARIABLES (RADIANT) DOUBLE PRECISION :: & FIT,FOT,FOB,FIB DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: & ITM,IBMTOT,IBPTOT,ITPTOT,MU !INTERNAL VARIABLES (DRIVER) INTEGER :: & L,LOOP,DUMMY,FILE_NUMWVN,I,J,NUMEXP,START,WVN_INDEX,X_SIZE DOUBLE PRECISION :: & ALBEDO_SAVE,DUMVAR,F_PERT_UP,GRAVITY,M_CO2,M_DRY_AIR,M_H2O,& R_DRY_AIR,TAU_GAS_SAVE,TSLOPE DOUBLE PRECISION :: & PI=3.1415926535897932D0 DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: & DELTAZ,DELTA_X,F,K_ALBEDO,RHO_AIR_RET,TAU_CO2,TAU_H2O DOUBLE PRECISION, DIMENSION(:,:), ALLOCATABLE :: & K CHARACTER(LEN=5) :: & STRING2 CHARACTER(LEN=17) :: & FORM CHARACTER(LEN=30) :: & PHASE_INFILE !MODEL ATMOSPHERE INPUT PARAMETERS INTEGER :: & NUMWVN DOUBLE PRECISION :: & PSURF INTEGER, DIMENSION(:), ALLOCATABLE :: & LVL DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: & ASPAR_AERO,ASPAR_CLD,CO2_LVL,CO2_RET,H2O_LVL,H2O_RET,& O3_LVL,P_LVL,P_RET,T_LVL,T_RET,Z_LVL,Z_RET DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: & KABS_CO2,KABS_H2O,SIGS_RAY_IN !TIMING RELATED VARIABLES INTEGER :: & JEL,JAC_COUNT,PAR ! REAL :: & ! TLOOP0,TLOOP1 ! REAL :: & ! ETIME ! REAL, DIMENSION(2) :: & ! ET !START PROGRAM PRINT*,'RUNNING radiant2s_driver_avey.f90' !OPEN the output file OPEN(UNIT=17, FILE='forward_output.dat') !DEFINE DRIVER INPUT !Flag for displaying user input to the screen, 0=no,1=yes DISPLAY_IN = 0 !DEFINE SOME RADIANT INPUTS (constants) STREAMS = 16 ! was 8 SJC QUAD = 1 DG = 0 VIEW_FLAG = 1 !user defined view angle PHI = 0.0D0 !azimuth angle EPS = 1.0D-5 !FOR RADIANTN CHECK AZIMUTHAL_RAD_ONLY = .FALSE.!.TRUE. FOURIER_TOL = 1.0D-8 SRC_FLAG = 1 !solar sources only FSUN = 1.0D0 !flux at toa at this wavelength PLANCK_FLAG = 2 !radiant flag WVN = 0.0D0 !wavelength for planck function WVNLO = 0.0D0 !radiant variable WVNHI = 1.0D0 !radiant variable TTOP = 0.0D0 !temperature of the top boundary TEMISS = 0.0D0 !emissivity of top boundary PERT_FLAG = 0 !use perterbation scheme 0=no,1=yes FLUXES = 0 !flux output flag 0=off,1=on WARNING_FLAG = 0 !radiant warning messages 0=off,1=on P_IO = 0 !radiant I/O flag 0=off,1=on R_IO = 0 !rad I/O flag 0=off,1=on FLUX_IO = 0 !flux test I/O flag 0=off,1=on L_IO = 0 !local I/O flag 0=off,1=on B_IO = 0 !build_layer I/O flag 0=off,1=on INV_IO = 0 !invert I/O flag 0=off,1=on SURF = 1.0 !type of reflecting surface 1=lambertian WVN_FLAG = 'NEW' !use saved matrices KFLAG = 1 !use saved matrices LAYCHG = 0 !layer saving mode !DEFINE RETRIEVAL INPUTS (SET 1 OF 2) NUMWVN = 1 !READ NUMLAY FROM THE FILE NUMLAY = 84 VIEW_ANGLE = 0.1D0 !ALLOCATE MEMORY FOR RADIANT ARRAYS N = STREAMS/2 + VIEW_FLAG !*** numlay is the number of layer midpoints !*** numlay+1 gives the number of boundary layers !allocate aerosol arrays (numlay) ALLOCATE( PF_AERO(NUMLAY),DELTA_M_AERO(NUMLAY),& CHI_AERO(0:(4*N),NUMLAY),& G1_AERO(NUMLAY),G2_AERO(NUMLAY),G_AERO(NUMLAY),& OMEGA_AERO(NUMLAY),TAU_AERO(NUMLAY),ASPAR_AERO(NUMLAY)) !allocate arrays (numlay) ALLOCATE ( PF_CLD(NUMLAY),DELTA_M_CLD(NUMLAY),& CHI_CLD(0:(4*N),NUMLAY),& G1_CLD(NUMLAY),G2_CLD(NUMLAY),G_CLD(NUMLAY),& TAU_GAS(NUMLAY),TAU_RAY(NUMLAY),& LVL(NUMLAY),RHO_AIR_LVL(NUMLAY),& TAU_CO2(NUMLAY),TAU_H2O(NUMLAY),DELTAZ(NUMLAY)& OMEGA_CLD(NUMLAY),TAU_CLD(NUMLAY)) !boundary values, not midpoints ALLOCATE( TLEV(NUMLAY+1) ) !TLEV(NUMLAY) !allocate arrays (N) ALLOCATE(CHI_SURF(0:(4*N)),ITMS(N),ITMT(N),ITM(N),& IBMTOT(N),IBPTOT(N),MU(N))!,ITPTOT(N), ) ! Only allocate if it hasn't already been allocated if (.not. allocated(ITPTOT)) allocate(ITPTOT(N)) !************************************************** !DEFINE MODEL ATMOSPHERE INPUT PARAMETERS ALLOCATE ( LVL(NUMLAY),RHO_AIR_RET(NUMLAY),& Z_LVL(NUMLAY),T_LVL(NUMLAY),P_LVL(NUMLAY),& CO2_LVL(NUMLAY),H2O_LVL(NUMLAY),O3_LVL(NUMLAY), & Z_RET(NUMLAY-1),T_RET(NUMLAY-1),P_RET(NUMLAY-1),& CO2_RET(NUMLAY-1),H2O_RET(NUMLAY-1),DELTAZ(NUMLAY-1),& ASPAR_CLD(NUMLAY) KABS_CO2(NUMLAY),KABS_H2O(NUMLAY),& SIGS_RAY_IN(NUMLAY),SZA_IN(NUMLAY),TSURF_IN(NUMLAY),VIEW_ANGLE_IN(NUMLAY)) !READ MODEL ATMOSPHERE GAS FILE OPEN(10,FILE='/scratch/local/savey_atrain2/savey_cloud_input.dat',STATUS='OLD') ! open(10,file='/Users/u0029340/Documents/idl_code/atrain_1/forward/savey_cloud_input.dat', status='old') ! DO I=1,7 ! READ(10,*) ! END DO DO I=1,NUMLAY !Note: Gases are mass mixing ratios READ(10,*) LVL(I),SZA_IN(I),TSURF_IN(I),VIEW_ANGLE_IN(I),Z_LVL(I),P_LVL(I),T_LVL(I),& TAU_CLD(I),OMEGA_CLD(I),ASPAR_CLD(I) ! H2O_LVL(I),CO2_LVL(I),O3_LVL(I),DUMVAR ! WRITE(*,10) LVL(I),,T_LVL(I),P_LVL(I),& ! H2O_LVL(I),CO2_LVL(I),O3_LVL(I),DUMVAR !10 FORMAT(2X,I2,2X,7(1X,E12.5E2)) END DO CLOSE (10) VIEW_ANGLE=VIEW_ANGLE_IN(1) ! PRINT*,VIEW_ANGLE, 'VIEW_ANGLE' P_LVL = P_LVL*100.0 !converting to Pa FORM = ADJUSTL('('//TRIM(STRING2(NUMWVN))//'(1X,E12.5))') !READ RAYLEIGH SCATTERING COEFFICIENTS (in km^-1) !AT THREE SAMPLE WAVENUMBERS ! OPEN(10,FILE='/uufs/chpc.utah.edu/common/home/u0476903/mw_fortran_code/forward/sigs_ray_sample.dat',STATUS='OLD') ! READ(10,*) FILE_NUMWVN ! IF (FILE_NUMWVN /= NUMWVN) THEN ! PRINT* ! PRINT*,'INPUT MISMATCH: NUMWVN FOR RETRIEVAL /= NUMWVN IN' ! PRINT*,'RAYLEIGH INPUT FILE' ! STOP ! END IF ! WRITE(*,*) ! WRITE(*,*) 'FILE "sigs_ray_sample.dat" LOOKS LIKE:' ! WRITE(*,*) ! DO I=1,NUMLAY ! READ(10,*) SIGS_RAY_IN(I,:) ! WRITE(*,FMT=FORM) SIGS_RAY_IN(I,:) ! END DO ! CLOSE (10) ! PRINT*,'HERE' OPEN(10,FILE='/scratch/local/savey_atrain2/savey_pro_input.dat',STATUS='OLD') ! open(10,file='/Users/u0029340/Documents/idl_code/atrain_1/forward/savey_pro_input.dat',status='old') ! DO I=1,7 ! READ(10,*) ! END DO DO I=1,NUMLAY READ(10,*) O3_LVL(I),CO2_LVL(I),H2O_LVL(I),SIGS_RAY_IN(I),KABS_H2O(I),KABS_CO2(I) ! PRINT*, I END DO CLOSE (10) ! PRINT*, SIGS_RAY_IN, 'SIGS_RAY' OPEN(10,FILE='/scratch/local/savey_atrain2/albedo_out.dat',STATUS='OLD') ! open(10,file='/Users/u0029340/Documents/idl_code/atrain_1/albedo/albedo_out.dat',status='old') READ(10,*) ALBEDO CLOSE(10) ! PRINT*,ALBEDO,'albedo' !READ MASS ABSORPTION COEFFICIENTS OF CO2 & H2O VAPOR (in cm^2/g) !AT THREE SAMPLE WAVENUMBERS ! OPEN(10,FILE='/uufs/chpc.utah.edu/common/home/u0476903/mw_fortran_code/forward/kabs_co2_sample.dat',STATUS='OLD') ! READ(10,*) FILE_NUMWVN ! IF (FILE_NUMWVN /= NUMWVN) THEN ! PRINT* ! PRINT*,'INPUT MISMATCH: NUMWVN FOR RETRIEVAL /= NUMWVN IN' ! PRINT*,'CO2 INPUT FILE' ! STOP ! END IF ! WRITE(*,*) ! WRITE(*,*) 'FILE "kabs_co2_sample.dat" LOOKS LIKE:' ! WRITE(*,*) ! DO I=1,NUMLAY ! READ(10,*) KABS_CO2(I,1:NUMWVN) ! WRITE(*,FMT=FORM) KABS_CO2(I,1:NUMWVN) ! END DO ! CLOSE (10) ! OPEN(10,FILE='/uufs/chpc.utah.edu/common/home/u0476903/mw_fortran_code/forward/kabs_h2o_sample.dat',STATUS='OLD') ! READ(10,*) FILE_NUMWVN ! IF (FILE_NUMWVN /= NUMWVN) THEN ! PRINT* ! PRINT*,'INPUT MISMATCH: NUMWVN FOR RETRIEVAL /= NUMWVN IN' ! PRINT*,'H2O VAPOR INPUT FILE' ! STOP ! END IF ! WRITE(*,*) ! WRITE(*,*) 'FILE "kabs_h2o_sample.dat" LOOKS LIKE:' ! WRITE(*,*) ! DO I=1,NUMLAY ! READ(10,*) KABS_H2O(I,1:NUMWVN) ! WRITE(*,FMT=FORM) KABS_H2O(I,1:NUMWVN) ! END DO ! CLOSE (10) ! PRINT*, KABS_H20 !DEFINE INPUT CLOUD PARAMETERS (OPTICAL DEPTH, SINGLE SCATTER !ALBEDO, ASSYMETRY PARAMETER). PLACE A CLOUD IN LAYER 5 !WITH TAU = 0.1, OMEGA_AERO = 0.97, AND ASPAR_AERO = 0.77 !(AS AN EXAMPLE) : ! PRINT*, NUMLAY !DEFINE INPUT AEROSOL PARAMETERS (OPTICAL DEPTH, SINGLE SCATTER !ALBEDO, ASSYMETRY PARAMETER). PLACE AN AEROSOL IN LAYER 10 !WITH TAU = 0.05, OMEGA_AERO = 0.85, AND ASPAR_AERO = 0.80 !(AS AN EXAMPLE) : TAU_AERO = 0.0D0 OMEGA_AERO = 0.0D0 ASPAR_AERO = 0.0D0 !DEFINE SURFACE PRESSURE PSURF = P_LVL(NUMLAY-1) !CONSTRUCT VECTORS OF HEIGHT, TEMPERATURE, THICKNESS, AND PRESSURE !FOR EACH LAYER IN THE RETRIEVAL ATMOSPHERE: !HEIGHT, TEMPERATURE, AND MASS MIXING RATIOS OF GASES IN CENTER !OF LAYERS (in km, K, and unitless) DO I=1,NUMLAY-1 Z_RET(I) = (Z_LVL(I) + Z_LVL(I+1))/2.0D0 T_RET(I) = (T_LVL(I) + T_LVL(I+1))/2.0D0 H2O_RET(I) = (H2O_LVL(I) + H2O_LVL(I+1))/2.0D0 CO2_RET(I) = (CO2_LVL(I) + CO2_LVL(I+1))/2.0D0 END DO ! print*, T_RET, 't_ret' !THICKNESSES OF LAYERS (in km) DO I=1,NUMLAY-1 DELTAZ(I) = Z_LVL(I) - Z_LVL(I+1) IF (DELTAZ(I) < 0.0D0) THEN WRITE(*,*) 'DELTAZ(I) < 0 FOR I = ',I STOP END IF END DO !PRESSURE AT CENTER OF LAYERS (in Pa) GRAVITY = 9.80665D0 !in m/s^2 R_DRY_AIR = 287.05D0 !in J/(kg*K) TSLOPE = (T_LVL(NUMLAY-1) - T_LVL(NUMLAY))/ & !in K/km (Z_LVL(NUMLAY-1) - Z_LVL(NUMLAY)) P_RET(NUMLAY-1) = PSURF*(T_RET(NUMLAY-1)/T_LVL(NUMLAY))** & (-1.0D3*GRAVITY/(R_DRY_AIR*TSLOPE)) ! print*,p_ret(numlay), 'p_ret' DO I=NUMLAY-2,1,-1 ! print*, p_ret(I+1), 'pret+1' ! print*, (T_RET(I)/T_RET(I+1)) TSLOPE = (T_RET(I) - T_RET(I+1))/(Z_RET(I)-Z_RET(I+1)) P_RET(I) = P_RET(I+1)*(T_RET(I)/T_RET(I+1))** & (-1.0D3*GRAVITY/(R_DRY_AIR*TSLOPE)) ! print*,p_ret(I), 'pret' END DO ! print*,p_ret, 'p_ret' ! print*,t_ret, 't_ret' !AIR DENSITY AT CENTER OF LAYERS (in kg/m^3) DO I=1,NUMLAY-1 RHO_AIR_RET(I) = P_RET(I)/(R_DRY_AIR*T_RET(I)) END DO ! WRITE(*,*) ! WRITE(*,*) 'PARAMETERS FOR THE RETRIEVAL ATMOSPHERE ARE' ! WRITE(*,*) '("RET" VALUES ARE AT CENTERS OF LAYERS):' ! WRITE(*,*) ! WRITE(*,*) 'LAYER',' DELTAZ ',' Z_RET ',& ! ' T_RET ',' P_RET ',' RHO_AIR_RET' DO I=1,NUMLAY ! WRITE(*,15) I,DELTAZ(I),Z_RET(I),T_RET(I),P_RET(I),RHO_AIR_RET(I) 15 FORMAT(2X,I2,2X,5(1X,E12.5E2)) END DO !DEFINE RETRIEVAL INPUTS (SET 2 OF 2) X_SIZE = 2*NUMLAY ALLOCATE ( DELTA_X(X_SIZE),TAU_CO2(NUMLAY),TAU_H2O(NUMLAY),& F(NUMWVN),K(NUMWVN,X_SIZE),K_ALBEDO(NUMWVN) ) !DEFINE MAGNITUDE TO PERTURB GASES FOR CORRESPONDING JACOBIAN !ELEMENT COMPUTATIONS. PUTTING CHANGE OF GAS CONCENTRATION !IN TERMS OF PPMV M_DRY_AIR = 28.96D0 !in g/mol M_CO2 = 44.01D0 !in g/mol M_H2O = 18.02D0 !in g/mol DELTA_X(1:NUMLAY) = EPS*((M_DRY_AIR/M_CO2)*1.0D6)*CO2_RET DELTA_X(NUMLAY+1:2*NUMLAY) = EPS*((M_DRY_AIR/M_H2O)*1.0D6)*H2O_RET !DEFINE SOME RADIANT INPUTS (SET 2 OF 2) SRC_FLAG = 1 SZA = (DACOS(1.0D0)/PI)*180.0D0 IF ((LOOP == 8).OR.(LOOP == 10) .OR.(LOOP == 22)) THEN SZA = (DACOS(1.0D0)/PI)*180.0D0 ELSE IF ((LOOP == 24).OR.(LOOP == 25)) THEN SZA = (DACOS(0.1D0)/PI)*180.0D0 END IF SZA = SZA_IN(1) ! PRINT*, SZA, 'SZA!' FSUN = 1.0D0 ITMS = 0.0D0 PLANCK_FLAG = 2 WVN = 0.0D0 WVNLO = 0.0D0 WVNHI = 1.0D0 ITMT = 0.0D0 TTOP = 0.0D0 TEMISS = 0.0D0 TLEV = 0.0D0 TSURF = TSURF_IN(1) PERT_FLAG = 0 FLUXES = 0 WARNING_FLAG = 0 P_IO = 0 R_IO = 0 FLUX_IO = 0 L_IO = 0 B_IO = 0 INV_IO = 0 !INITIALIZE OUTPUT F = 0.0D0 K = 0.0D0 K_ALBEDO = 0.0D0 JAC_COUNT = 0 ! TLOOP0 = ETIME(ET) !START OF VECTOR F / JACOBIAN K LOOP DO WVN_INDEX = 1,NUMWVN !PRINT* !PRINT*,'NEW WVN' DO I=1,NUMLAY !RAYLEIGH OPTICAL DEPTH TAU_RAY(I) = SIGS_RAY_IN(I)*DELTAZ(I) !print*, TAU_RAY, 'TAU_RAY' !GAS OPTICAL DEPTHS TAU_CO2(I) = KABS_CO2(I)*CO2_RET(I)* & RHO_AIR_RET(I)*1.0D2*DELTAZ(I) TAU_H2O(I) = KABS_H2O(I)*H2O_RET(I)* & RHO_AIR_RET(I)*1.0D2*DELTAZ(I) TAU_GAS(I) = TAU_CO2(I) + TAU_H2O(I) END DO ! print*, tau_gas, 'tau_gas' ! print*, tau_h2o ! print*, rho_air_ret, 'rho_air_ret' ! print*, deltaz, 'deltaz' ! tau_gas(:)=0.00 ! SJC DO I=1,NUMLAY PF_CLD(I) = 1 G1_CLD(I) = ASPAR_CLD(I) G2_CLD(I) = 0.0D0 G_CLD(I) = ASPAR_CLD(I) !IF (LOOP == 50) THEN !IF ((LOOP == 31) .OR. (LOOP == 36).OR. (LOOP == 39)) THEN ! G1_CLD(I) = 0.999999999D0 !ELSE IF ((LOOP == 32) .OR. (LOOP == 37).OR. (LOOP == 40)) THEN ! G1_CLD(I) = 0.85D0 !ELSE IF ((LOOP == 33) .OR. (LOOP == 38).OR. (LOOP == 41)) THEN ! G1_CLD(I) = 0.00D0 !ELSE IF (LOOP == 34) THEN ! G1_CLD(I) = -0.85D0 !ELSE IF (LOOP == 35) THEN ! G1_CLD(I) = -0.999999999D0 !END IF !IF ((LOOP == 31) .OR. (LOOP == 32).OR. (LOOP == 33) & ! .OR. (LOOP == 34).OR. (LOOP == 35)) THEN ! G2_CLD(I) = 0.00D0 !ELSE IF ((LOOP == 36) .OR. (LOOP == 37).OR. (LOOP == 38)) THEN ! G2_CLD(I) = -0.50D0 !ELSE IF ((LOOP == 39) .OR. (LOOP == 40).OR. (LOOP == 41)) THEN ! G2_CLD(I) = -0.999999999D0 !END IF !IF (LOOP == 31) THEN ! G_CLD(I) = 0.999999999D0 !ELSE IF (LOOP == 32) THEN ! G_CLD(I) = 0.85D0 !ELSE IF (LOOP == 33) THEN ! G_CLD(I) = 0.00D0 !ELSE IF (LOOP == 34) THEN ! G_CLD(I) = -0.85D0 !ELSE IF (LOOP == 35) THEN ! G_CLD(I) = -0.999999999D0 !ELSE IF (LOOP == 36) THEN ! G_CLD(I) = 0.70D0 !ELSE IF (LOOP == 37) THEN ! G_CLD(I) = 0.58D0 !ELSE IF (LOOP == 38) THEN ! G_CLD(I) = -0.10D0 !ELSE IF (LOOP == 39) THEN ! G_CLD(I) = 0.60D0 !ELSE IF (LOOP == 40) THEN ! G_CLD(I) = 0.48D0 !ELSE IF (LOOP == 41) THEN ! G_CLD(I) = -0.20D0 !END IF !END IF CHI_CLD(:,I) = 0.0D0 DELTA_M_CLD(I) = 0.0 END DO DO I=1,NUMLAY PF_AERO(I) = 1 G1_AERO(I) = ASPAR_AERO(I) G2_AERO(I) = 0.0D0 G_AERO(I) = ASPAR_AERO(I) !IF (LOOP == 50) THEN !IF ((LOOP == 31) .OR. (LOOP == 36).OR. (LOOP == 39)) THEN ! G1_AERO(I) = 0.999999999D0 !ELSE IF ((LOOP == 32) .OR. (LOOP == 37).OR. (LOOP == 40)) THEN ! G1_AERO(I) = 0.85D0 !ELSE IF ((LOOP == 33) .OR. (LOOP == 38).OR. (LOOP == 41)) THEN ! G1_AERO(I) = 0.00D0 !ELSE IF (LOOP == 34) THEN ! G1_AERO(I) = -0.85D0 !ELSE IF (LOOP == 35) THEN ! G1_AERO(I) = -0.999999999D0 !END IF ! !IF ((LOOP == 31) .OR. (LOOP == 32).OR. (LOOP == 33) & ! .OR. (LOOP == 34).OR. (LOOP == 35)) THEN ! G2_AERO(I) = 0.00D0 !ELSE IF ((LOOP == 36) .OR. (LOOP == 37).OR. (LOOP == 38)) THEN ! G2_AERO(I) = -0.50D0 !ELSE IF ((LOOP == 39) .OR. (LOOP == 40).OR. (LOOP == 41)) THEN ! G2_AERO(I) = -0.999999999D0 !END IF !IF (LOOP == 31) THEN ! G_AERO(I) = 0.999999999D0 !ELSE IF (LOOP == 32) THEN ! G_AERO(I) = 0.85D0 !ELSE IF (LOOP == 33) THEN ! G_AERO(I) = 0.00D0 !ELSE IF (LOOP == 34) THEN ! G_AERO(I) = -0.85D0 !ELSE IF (LOOP == 35) THEN ! G_AERO(I) = -0.999999999D0 !ELSE IF (LOOP == 36) THEN ! G_AERO(I) = 0.70D0 !ELSE IF (LOOP == 37) THEN ! G_AERO(I) = 0.58D0 !ELSE IF (LOOP == 38) THEN ! G_AERO(I) = -0.10D0 !ELSE IF (LOOP == 39) THEN ! G_AERO(I) = 0.60D0 !ELSE IF (LOOP == 40) THEN ! G_AERO(I) = 0.48D0 !ELSE IF (LOOP == 41) THEN ! G_AERO(I) = -0.20D0 !END IF !END IF CHI_AERO(:,I) = 0.0D0 DELTA_M_AERO(I) = 1 END DO !TEST PHASE FUNCTION INPUT !PF_AERO(10) = 2 !G1_AERO(10) = 0.0D0 !G2_AERO(10) = 0.0D0 !G_AERO(10) = 0.0D0 !PHASE_INFILE = 'infiles/phase/phase3_01_02.dat' !OPEN (UNIT=34,FILE=PHASE_INFILE,STATUS='OLD') !DO J=1,10 ! READ(34,*) !END DO !DO J=0,4*N ! READ (34,*) DUMMY,CHI_AERO(J,10) !END DO !CLOSE (34) SURF = 1.0 ! ALBEDO = 0.024D0 ! albedo CHI_SURF = 0.0D0 !TEST SURFACE INPUT !SURF = 2 !ALBEDO = 0.00D0 !OPEN (UNIT=34,FILE='infiles/surf/surf6_01_03.dat',STATUS='OLD') !DO I=1,8 ! READ(34,*) !END DO !READ(34,*) NUMEXP !DO L=0,NUMEXP-1 ! READ(34,*) DUMMY, CHI_SURF(L) !END DO !CLOSE(34) !DISPLAY INPUTS IF DESIRED IF (DISPLAY_IN == 1) THEN CALL DISPLAY_INPUT(STREAMS,N,NUMLAY,VIEW_FLAG,VIEW_ANGLE,& SRC_FLAG,FSUN,SZA,ITMS,ITMT,TTOP,TEMISS,TLEV,TSURF,& PLANCK_FLAG,WVN,WVNLO,WVNHI,PHI,QUAD,DG,& TAU_RAY,TAU_GAS,TAU_AERO,TAU_CLD,OMEGA_AERO,OMEGA_CLD,& G1_CLD,G2_CLD,G_CLD,G1_AERO,G2_AERO,G_AERO,PF_CLD,& CHI_CLD,PF_AERO,CHI_AERO,DELTA_M_CLD,DELTA_M_AERO,& SURF,ALBEDO,CHI_SURF,WVN_FLAG,KFLAG,AZIMUTHAL_RAD_ONLY,& FOURIER_TOL,FLUXES,WARNING_FLAG,& P_IO,R_IO,FLUX_IO,L_IO,B_IO,INV_IO) END IF ! JAC_COUNT = 0 ! TLOOP0 = ETIME(ET) ! SPECIAL JACOBIAN TIMING LOOP DO L=1,1 !50 !COMPUTE RADIANCE OF BASE STATE AT THE GIVEN WAVENUMBER WVN_FLAG = 'NEW' KFLAG = 1 LAYCHG = 0 !IF (LOOP == 26) THEN ! P_IO = 1 ! R_IO = 1 ! L_IO = 1 ! B_IO = 1 !END IF CALL RADIANT(N,NUMLAY,VIEW_FLAG,VIEW_ANGLE,SRC_FLAG,FSUN,SZA,& ITMS,ITMT,TTOP,TEMISS,TLEV,TSURF,PLANCK_FLAG,WVN,WVNLO,WVNHI,& PHI,QUAD,DG,TAU_RAY,TAU_GAS,TAU_AERO,TAU_CLD,OMEGA_AERO,& OMEGA_CLD,G1_CLD,G2_CLD,G_CLD,G1_AERO,G2_AERO,G_AERO,& PF_CLD,CHI_CLD,PF_AERO,CHI_AERO,DELTA_M_CLD,DELTA_M_AERO,& SURF,ALBEDO,CHI_SURF,WVN_FLAG,KFLAG,LAYCHG,PERT_FLAG,EPS,& AZIMUTHAL_RAD_ONLY,FOURIER_TOL,FLUXES,WARNING_FLAG,& P_IO,R_IO,FLUX_IO,L_IO,B_IO,INV_IO,ITM,IBMTOT,IBPTOT,ITPTOT,& FIT,FOT,FOB,FIB,MU) !IF (LOOP == 26) THEN ! PRINT* ! PRINT*,'ITPTOT=',ITPTOT ! PRINT* ! PRINT*,'ITPTOT(N)=',ITPTOT(N) ! STOP !END IF F(WVN_INDEX) = ITPTOT(N) START = 0 !PRINT* !JACOBIAN PAR LOOP DO PAR=1,1 !3 !COMPUTE RADIANCES OF PERTURBED STATES AT THE GIVEN WAVENUMBER !FOR CO2 & CORRESPONDING JACOBIAN ELEMENTS DO I=1,NUMLAY !PRINT*,'LAYER = ',I WVN_FLAG = 'OLD' KFLAG = 1 LAYCHG = 0 !PERTURB SIGE_CO2 AT CURRENT LAYER UP FOR JACOBIAN ELEMENT !COMPUTATION TAU_GAS_SAVE = TAU_GAS(I) TAU_GAS(I) = TAU_CO2(I)*(1.0D0+EPS) + TAU_H2O(I) CALL RADIANT(N,NUMLAY,VIEW_FLAG,VIEW_ANGLE,SRC_FLAG,FSUN,SZA,& ITMS,ITMT,TTOP,TEMISS,TLEV,TSURF,PLANCK_FLAG,WVN,WVNLO,WVNHI,& PHI,QUAD,DG,TAU_RAY,TAU_GAS,TAU_AERO,TAU_CLD,OMEGA_AERO,& OMEGA_CLD,G1_CLD,G2_CLD,G_CLD,G1_AERO,G2_AERO,G_AERO,& PF_CLD,CHI_CLD,PF_AERO,CHI_AERO,DELTA_M_CLD,DELTA_M_AERO,& SURF,ALBEDO,CHI_SURF,WVN_FLAG,KFLAG,LAYCHG,PERT_FLAG,EPS,& AZIMUTHAL_RAD_ONLY,FOURIER_TOL,FLUXES,WARNING_FLAG,& P_IO,R_IO,FLUX_IO,L_IO,B_IO,INV_IO,ITM,IBMTOT,IBPTOT,ITPTOT,& FIT,FOT,FOB,FIB,MU) F_PERT_UP = ITPTOT(N) !COMPUTE JACOBIAN ELEMENT J = START + I K(WVN_INDEX,J) = (F_PERT_UP - F(WVN_INDEX))/DELTA_X(J) !PLACE ORIGINAL VALUE OF TAU_GAS(I) BACK IN ITS LOCATION TAU_GAS(I) = TAU_GAS_SAVE JAC_COUNT = JAC_COUNT + 1 END DO !COMPUTE RADIANCES OF PERTURBED STATES AT THE GIVEN WAVENUMBER !FOR SURFACE ALBEDO & CORRESPONDING JACOBIAN ELEMENTS WVN_FLAG = 'OLD' KFLAG = 1 LAYCHG = 0 !PERTURB SURFACE ALBEDO UP FOR JACOBIAN ELEMENT COMPUTATION ALBEDO_SAVE = ALBEDO ALBEDO = ALBEDO*(1.0D0+EPS) CALL RADIANT(N,NUMLAY,VIEW_FLAG,VIEW_ANGLE,SRC_FLAG,FSUN,SZA,& ITMS,ITMT,TTOP,TEMISS,TLEV,TSURF,PLANCK_FLAG,WVN,WVNLO,WVNHI,& PHI,QUAD,DG,TAU_RAY,TAU_GAS,TAU_AERO,TAU_CLD,OMEGA_AERO,& OMEGA_CLD,G1_CLD,G2_CLD,G_CLD,G1_AERO,G2_AERO,G_AERO,& PF_CLD,CHI_CLD,PF_AERO,CHI_AERO,DELTA_M_CLD,DELTA_M_AERO,& SURF,ALBEDO,CHI_SURF,WVN_FLAG,KFLAG,LAYCHG,PERT_FLAG,EPS,& AZIMUTHAL_RAD_ONLY,FOURIER_TOL,FLUXES,WARNING_FLAG,& P_IO,R_IO,FLUX_IO,L_IO,B_IO,INV_IO,ITM,IBMTOT,IBPTOT,ITPTOT,& FIT,FOT,FOB,FIB,MU) F_PERT_UP = ITPTOT(N) !COMPUTE JACOBIAN ELEMENT ! print*, f_pert_up, 'f_pert_up' ! print*, f(wvn_index), 'f' ! print*, albedo*eps, 'albedo*eps' K_ALBEDO(WVN_INDEX) = (F_PERT_UP - F(WVN_INDEX))/(ALBEDO*EPS) !PLACE ORIGINAL VALUE OF ALBEDO BACK IN ITS LOCATION ALBEDO = ALBEDO_SAVE !END OF JACOBIAN PAR LOOP END DO ! END OF SPECIAL JACOBIAN TIMING LOOP END DO ! TLOOP1 = ETIME(ET) ! PRINT* ! PRINT*,'THE TIMING RESULTS ARE:' ! PRINT*,'JAC_COUNT = ',JAC_COUNT*99 ! PRINT*,'JACOBIAN TIME =', TLOOP1 - TLOOP0 ! STOP !END OF VECTOR F / JACOBIAN K LOOP END DO ! TLOOP1 = ETIME(ET) ! PRINT* ! PRINT*,'THE TIMING RESULTS ARE:' ! PRINT*,'JAC_COUNT = ',JAC_COUNT ! PRINT*,'JACOBIAN TIME =', TLOOP1 - TLOOP0 ! STOP !DISPLAY RESULTS ... ! print* DO WVN_INDEX = 1, NUMWVN ! print*,'F(WVN_INDEX) = ',F(WVN_INDEX) END DO !... FOR VECTOR F SAMPLE ! WRITE(*,*) ! WRITE(*,*) 'VECTOR F SAMPLE LOOKS LIKE:' FORM = ADJUSTL('('//TRIM(STRING2(1))//'(1X,E15.8))') ! WRITE(*,FMT=TRIM(FORM)) (F(I),I=1,NUMWVN) !... FOR JACOBIAN K ! WRITE(*,*) ! WRITE(*,*) 'JACOBIAN K SAMPLE LOOKS LIKE:' FORM = ADJUSTL('('//TRIM(STRING2(X_SIZE/2))//'(1X,E15.8))') ! WRITE(*,FMT=TRIM(FORM)) ((K(I,J),J=1,X_SIZE/2),I=1,NUMWVN) ! !... FOR SURFACE ALBEDO JACOBIAN K_ALBEDO ! WRITE(*,*) ! WRITE(*,*) 'SURFACE ALBEDO JACOBIAN K_ALBEDO SAMPLE LOOKS LIKE:' FORM = ADJUSTL('(1X,E15.8)') WRITE(*,FMT=TRIM(FORM)) (K_ALBEDO(I),I=1,NUMWVN) ! PRINT*, FIT, 'FIT' ! write(*,*) ! write(*,*) 'top radiance',ITPTOT ! write(*,*) ITPTOT ! PRINT*,MU,'MU' WRITE(17,*) 'TOP RADIANCE' WRITE(17,*) ITPTOT(1), MU(1) WRITE(17,*) ITPTOT(2), MU(2) WRITE(17,*) ITPTOT(3), MU(3) WRITE(17,*) ITPTOT(4), MU(4) WRITE(17,*) ITPTOT(5), MU(5) WRITE(17,*) ITPTOT(6), MU(6) WRITE(17,*) ITPTOT(7), MU(7) WRITE(17,*) ITPTOT(8), MU(8) WRITE(17,*) ITPTOT(9), MU(9) ! write(*,*) tau_cld !DEALLOCATE ARRAYS TO PREPARE FOR NEXT TEST DEALLOCATE ( PF_AERO,PF_CLD,DELTA_M_AERO,DELTA_M_CLD,& CHI_AERO,CHI_CLD,OMEGA_AERO,OMEGA_CLD,& G1_AERO,G2_AERO,G_AERO,G1_CLD,G2_CLD,G_CLD,& TAU_AERO,TAU_CLD,TAU_GAS,TAU_RAY,& CHI_SURF,TLEV,ITMS,ITMT,ITM,IBMTOT,IBPTOT,ITPTOT ) DEALLOCATE ( LVL,RHO_AIR_RET,& Z_LVL,T_LVL,P_LVL,CO2_LVL,H2O_LVL,O3_LVL, & Z_RET,T_RET,P_RET,CO2_RET,H2O_RET,DELTAZ,& ASPAR_CLD,ASPAR_AERO,KABS_CO2,KABS_H2O,SIGS_RAY_IN ) DEALLOCATE ( DELTA_X,TAU_CO2,TAU_H2O,F,K,K_ALBEDO ) !END OF "VARIABLE N, NUMLAY, SZA, QUAD, DG, VIEW_FLAG, VIEW_ANGLE !CHANGE" & "PF HG/DHG" TEST LOOPS END DO close(17) !END PROGRAM ! PRINT* ! PRINT*,'radiant2s_driver_example2.f90 DONE' ! PRINT*,'**********************************************************' ! PRINT*,'**********************************************************' ! PRINT* END PROGRAM RADIANT2S_DRIVER_AVEY !******************************************************************************* !******************************************************************************* SUBROUTINE DISPLAY_INPUT(STREAMS,N,NUMLAY,VIEW_FLAG,VIEW_ANGLE,& SRC_FLAG,FSUN,SZA,ITMS,ITMT,TTOP,TEMISS,TLEV,TSURF,& PLANCK_FLAG,WVN,WVNLO,WVNHI,PHI,QUAD,DG,& TAU_RAY,TAU_GAS,TAU_AERO,TAU_CLD,OMEGA_AERO,OMEGA_CLD,& G1_CLD,G2_CLD,G_CLD,G1_AERO,G2_AERO,G_AERO,PF_CLD,& CHI_CLD,PF_AERO,CHI_AERO,DELTA_M_CLD,DELTA_M_AERO,& SURF,ALBEDO,CHI_SURF,WVN_FLAG,KFLAG,AZIMUTHAL_RAD_ONLY,& FOURIER_TOL,FLUXES,WARNING_FLAG,& P_IO,R_IO,FLUX_IO,L_IO,B_IO,INV_IO) !INPUT : STREAMS,N,NUMLAY,VIEW_FLAG,VIEW_ANGLE, ! SRC_FLAG,FSUN,SZA,ITMS,ITMT,TTOP,TEMISS,TLEV,TSURF, ! PLANCK_FLAG,WVN,WVNLO,WVNHI,PHI,QUAD,DG, ! TAU_RAY,TAU_GAS,TAU_AERO,TAU_CLD,OMEGA_AERO,OMEGA_CLD, ! G1_CLD,G2_CLD,G_CLD,G1_AERO,G2_AERO,G_AERO,PF_CLD, ! CHI_CLD,PF_AERO,CHI_AERO,DELTA_M_CLD,DELTA_M_AERO, ! SURF,ALBEDO,CHI_SURF,WVN_FLAG,KFLAG,FLUXES,WARNING_FLAG, ! P_IO,R_IO,FLUX_IO,L_IO,B_IO,INV_IO !OUTPUT: NONE !THIS PROGRAM DISPLAYS THE INPUTS FOR RADIANT !PROGRAMMER: MATT CHRISTI IMPLICIT NONE !INPUT VARIABLES (DRIVER) INTEGER :: & STREAMS !INPUT VARIABLES (RADIANT) INTEGER :: & B_IO,DG,FLUX_IO,FLUXES,INV_IO,KFLAG,L_IO,N,& NUMLAY,P_IO,PLANCK_FLAG,QUAD,R_IO,SRC_FLAG,& SURF,TEST,VIEW_FLAG,WARNING_FLAG INTEGER, DIMENSION(NUMLAY) :: & DELTA_M_AERO,DELTA_M_CLD,PF_AERO,PF_CLD DOUBLE PRECISION :: & ALBEDO,BSURF,BTOP,FSUN,PHI,FOURIER_TOL,& SZA,TEMISS,TSURF,TTOP,VIEW_ANGLE,WVN,WVNLO,WVNHI DOUBLE PRECISION, DIMENSION(N) :: & ITMS,ITMT DOUBLE PRECISION, DIMENSION(NUMLAY) :: & G_AERO,G_CLD,G1_AERO,G1_CLD,G2_AERO,G2_CLD,& TAU_RAY,TAU_GAS,TAU_AERO,TAU_CLD,OMEGA_AERO,OMEGA_CLD DOUBLE PRECISION, DIMENSION(NUMLAY+1) :: & TLEV DOUBLE PRECISION, DIMENSION(0:(4*N)) :: & CHI_SURF DOUBLE PRECISION, DIMENSION(0:(4*N),NUMLAY) :: & CHI_AERO,CHI_CLD CHARACTER (LEN=3) :: & WVN_FLAG LOGICAL :: & AZIMUTHAL_RAD_ONLY !INTERNAL VARIABLES INTEGER :: & I,MOMENT DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: & TAU CHARACTER (LEN=3) :: & FORMAT_STRING CHARACTER (LEN=4) :: & FORM1 CHARACTER (LEN=20) :: & FORM2 !START PROGRAM ! PRINT* ! PRINT*,'*** THE INPUTS FOR THE ATMOSPHERIC SCENE ARE: ***' ! PRINT* ! PRINT*,'# OF STREAMS TO COMPUTE RADIANCE FIELD = ',STREAMS IF (QUAD == 0) THEN IF (DG == 0) THEN PRINT*,'USING GAUSS' ELSE PRINT*,'USING DOUBLE GAUSS' END IF ELSE IF (QUAD == 1) THEN PRINT*,'USING LOBATTO' END IF ! PRINT*,'NUMLAY = ',NUMLAY ! PRINT* ! PRINT*,'VIEW_FLAG = ',VIEW_FLAG IF (VIEW_FLAG == 1) THEN PRINT*,'VIEW_ANGLE = ',VIEW_ANGLE END IF PRINT* PRINT*,'PHI = ',PHI PRINT*,'AZIMUTHAL_RAD_ONLY = ',AZIMUTHAL_RAD_ONLY PRINT*,'FOURIER_TOL = ',FOURIER_TOL PRINT* PRINT*,'SRC_FLAG = ',SRC_FLAG IF (SRC_FLAG == 1) THEN PRINT*,'ONLY SOLAR SOURCES IN USE' ELSE IF (SRC_FLAG == 2) THEN PRINT*,'SOLAR AND THERMAL SOURCES IN USE' ELSE IF (SRC_FLAG == 3) THEN PRINT*,'ONLY THERMAL SOURCES IN USE' END IF IF ((SRC_FLAG == 1).OR.(SRC_FLAG == 2)) THEN PRINT* PRINT*,'FSUN = ',FSUN PRINT*,'SZA = ',SZA PRINT* PRINT*,'ITMS:' DO I=N,1,-1 WRITE(*,10) N-I+1,ITMS(I) END DO END IF IF ((SRC_FLAG == 2).OR.(SRC_FLAG == 3)) THEN IF (TTOP == 0.0D0) THEN PRINT* PRINT*,'ITMT:' DO I=N,1,-1 WRITE(*,10) N-I+1,ITMT(I) END DO ELSE PRINT* PRINT*,'TTOP = ',TTOP PRINT* PRINT*,'TEMISS = ',TEMISS END IF PRINT* WRITE(*,40) 'LEVEL',' TLEV ' DO I=1,NUMLAY+1 WRITE(*,10) I,TLEV(I) END DO PRINT* PRINT*,'TSURF = ',TSURF PRINT* PRINT*,'PLANCK_FLAG = ',PLANCK_FLAG IF (PLANCK_FLAG == 1) THEN PRINT*,'WVN = ',WVN ELSE IF (PLANCK_FLAG == 2) THEN PRINT*,'WVNLO = ',WVNLO PRINT*,'WVNHI = ',WVNHI END IF END IF PRINT* WRITE(*,40) 'LAYER','TAU_RAY ' DO I=1,NUMLAY WRITE(*,10) I,TAU_RAY(I) END DO PRINT* WRITE(*,40) 'LAYER','TAU_GAS ' DO I=1,NUMLAY WRITE(*,10) I,TAU_GAS(I) END DO !PREPARE FORMATTING FOR CLOUD & AEROSOL DATA FORM1 = '(I1)' WRITE(FORMAT_STRING,FORM1) 5 FORM2 = '(' // FORMAT_STRING // '(1X,E15.9E2,1X))' PRINT* WRITE(*,37) 'LAYER','OMEGA_CLD',' TAU_CLD ','PF_CLD ', & 'DELTA_M_CLD ','G1_CLD ','G2_CLD ','G_CLD ' DO I=1,NUMLAY WRITE(*,33) I,OMEGA_CLD(I),TAU_CLD(I),PF_CLD(I), & DELTA_M_CLD(I),G1_CLD(I),G2_CLD(I),G_CLD(I) END DO PRINT* WRITE(*,*) 'CHI_CLD =' DO I=1,NUMLAY WRITE(*,*) 'LAYER',I WRITE(*,FORM2) (CHI_CLD(MOMENT,I),MOMENT=0,4*N) END DO PRINT* WRITE(*,37) 'LAYER','OMEGA_AERO','TAU_AERO ','PF_AERO', & 'DELTA_M_AERO','G1_AERO','G2_AERO','G_AERO ' DO I=1,NUMLAY WRITE(*,33) I,OMEGA_AERO(I),TAU_AERO(I),PF_AERO(I), & DELTA_M_AERO(I),G1_AERO(I),G2_AERO(I),G_AERO(I) END DO PRINT* WRITE(*,*) 'CHI_AERO =' DO I=1,NUMLAY WRITE(*,*) 'LAYER',I WRITE(*,FORM2) (CHI_AERO(MOMENT,I),MOMENT=0,4*N) END DO 33 FORMAT(2X,I3,2X,2(2X,E15.9E2,1X),4X,I2,10X,I1,8X,3(2X,E15.9E2,1X)) 37 FORMAT(1X,A5,1X,2(5X,A9,4X),2X,A7,2X,1(1X,A12,1X),3(6X,A7,5X), & 1X,1(1X,A12,1X)) PRINT* IF (SURF == 0) THEN PRINT*,'SURFACE = NONE' ELSE IF (SURF == 1) THEN PRINT*,'SURFACE = LAMBERTIAN' PRINT*,'ALBEDO = ',ALBEDO ELSE PRINT*,'SURFACE = NONLAMBERTIAN' PRINT* WRITE(*,*) 'CHI_SURF =' WRITE(*,FORM2) (CHI_SURF(MOMENT),MOMENT=0,4*N) END IF PRINT* PRINT*,'WVN_FLAG = ',WVN_FLAG PRINT*,'KFLAG = ',KFLAG IF ((WVN_FLAG == 'NEW').AND.(KFLAG == 0)) THEN PRINT*,'WVN_FLAG AND KFLAG SET TO COMPUTE RADIANCES ONLY' ELSE IF ((WVN_FLAG == 'NEW').AND.(KFLAG == 1)) THEN PRINT*,'WVN_FLAG AND KFLAG SET TO COMPUTE RADIANCES AND ' // & 'SAVE LAYERS FOR NEXT CALL' ELSE IF ((WVN_FLAG == 'OLD').AND.(KFLAG == 1)) THEN PRINT*,'WVN_FLAG AND KFLAG SET TO COMPUTE RADIANCES ' // & 'USING SAVED LAYERS' END IF PRINT* PRINT*,'FLUXES = ',FLUXES PRINT*,'WARNING_FLAG = ',WARNING_FLAG PRINT*,'P_IO = ',P_IO PRINT*,'R_IO = ',R_IO PRINT*,'FLUX_IO = ',FLUX_IO PRINT*,'L_IO = ',L_IO PRINT*,'B_IO = ',B_IO PRINT*,'INV_IO = ',INV_IO 10 FORMAT(2X,I3,5X,E15.9E2) 20 FORMAT(1X,I3,3X,3(3X,E15.9E2)) 30 FORMAT(1X,I3,3X,2(3X,E15.9E2)) 32 FORMAT(2X,I3,5X,I1,7X,A7,9X,I1) 40 FORMAT(1X,A5,7X,A8) 45 FORMAT(2X,A5,6X,A10) 65 FORMAT(2X,A5,2(5X,A11,2X)) PRINT* PRINT*,'DERIVED LAYER OPTICAL DEPTHS FROM INPUT PARAMETERS:' PRINT*,'(FOR INFORMATION ONLY)' WRITE(*,40) 'LAYER',' TAU ' ALLOCATE ( TAU(NUMLAY) ) DO I=1,NUMLAY TAU(I) = TAU_CLD(I) + TAU_AERO(I) + TAU_GAS(I) + TAU_RAY(I) WRITE(*,10) I,TAU(I) END DO DEALLOCATE (TAU) PRINT* PRINT*,'*** END OF INPUTS ***' RETURN END SUBROUTINE DISPLAY_INPUT !******************************************************************************* !******************************************************************************* FUNCTION STRING2(NUM) !INPUT : NUM !OUTPUT: STRING !THIS FUNCTION CONVERTS AN INTEGER WITH UP TO 5 DIGITS TO A CHARACTER STRING !(WITH POSSIBLE TRAILING BLANKS - USE THIS FUNCTION WITH INTRINSIC FUNCTION !"TRIM" TO ELIMINATE ANY TRAILING BLANKS) !PROGRAMMER: MATT CHRISTI !DATA DICTIONARY******************************************************** ! ! !*********************************************************************** !INTRINSIC SUBPROGRAMS USED ******************************************** ! DBLE,MOD,INT,ADJUSTL !*********************************************************************** !EXTERNAL SUBPROGRAMS USED ********************************************* ! NONE !*********************************************************************** IMPLICIT NONE !INPUT VARIABLES INTEGER :: & NUM !OUTPUT VARIABLES CHARACTER(LEN=5) :: & STRING2 !INTERNAL VARIABLES INTEGER :: & I,N1,DIGIT CHARACTER(LEN=1), DIMENSION(0:10) :: & NUM_LET CHARACTER(LEN=1), DIMENSION(5) :: & STR DATA NUM_LET/'0','1','2','3','4','5','6','7','8','9',' '/ !START PROGRAM ! PRINT* ! PRINT*,'ENTERING STRING' !CONVERT DIGITS OF INTEGER TO STRING N1 = NUM DO I=5,1,-1 DIGIT = INT(MOD(DBLE(N1),10.0D0)) STR(I) = NUM_LET(DIGIT) N1 = (N1 - DIGIT)/10 END DO !CHANGE LEADING ZEROS OF INTEGER PORTION TO BLANKS I = 0 DO I = I + 1 IF ((STR(I) == '0').AND.(I /= 5)) THEN STR(I) = ' ' ELSE EXIT END IF END DO !PREPARE OUTPUT STRING2 = STR(1)//STR(2)//STR(3)//STR(4)//STR(5) STRING2 = ADJUSTL(STRING2) !END PROGRAM ! PRINT* ! PRINT*,'LEAVING STRING' RETURN END FUNCTION STRING2 !********************************************************************** !**********************************************************************