├── README.md ├── Version ├── _disort.pyf ├── doc ├── Makefile ├── README ├── make.bat └── source │ ├── conf.py │ ├── disort.rst │ └── index.rst ├── lib └── disort │ ├── __init__.py │ └── __version__.py ├── setup.py ├── src └── disort │ ├── Driver.f │ └── src │ ├── BDREF.f │ ├── DISORT.f │ ├── ErrPack.f │ ├── GETMOM.f │ ├── LINPAK.f │ ├── PRTFIN.f │ └── RDI1MACH.f └── test ├── rayleigh_layer_opd.txt ├── test_Rayleigh.py └── test_disort.py /README.md: -------------------------------------------------------------------------------- 1 | # pyDISORT 2 | 3 | Python wrapper to the DISORT¹ radiative transfer solver. 4 | 5 | (1) K. Stamnes, SC. Tsay, W. Wiscombe and K. Jayaweera, Numerically 6 | stable algorithm for discrete-ordinate-method radiative 7 | transfer in multiple scattering and emitting layered media, 8 | Appl Opt 27 (1988) (12), pp. 2502–2509. 9 | 10 | ## Installation 11 | 12 | Go to the directory where you have checked out the pyDISORT project and run the following command: 13 | 14 | sudo python setup.py install 15 | 16 | ## Documentation 17 | 18 | >>> import disort 19 | >>> help(disort.run) 20 | 21 | performs radiative transfer simulations by means of the DISORT RT solver 22 | 23 | Parameters 24 | ---------- 25 | dTau : array 26 | optical thickness in atmospheric layers 27 | w0 : float, array 28 | single scattering albedo (Default: 1.) 29 | iphas : int, array 30 | scattering phase function type (Default 2). 31 | 1 : Isotropic 32 | 2 : Rayleigh 33 | 3 : Henyey-Greenstein with asymmetry factor GG 34 | 4 : Haze L as specified by Garcia/Siewert 35 | 5 : Cloud C.1 as specified by Garcia/Siewert 36 | gg : float, array 37 | scattering asymmetry parameter (Default: 0.85) 38 | umu0 : float 39 | cosine of solar zenith angle (Default: 1.) 40 | phi0 : float 41 | solar azimuth angle (Default: 0.) 42 | albedo : float 43 | surface albedo (Default: 0.1) 44 | fbeam : float 45 | solar irradiance (Default: 1.) 46 | utau : float, array 47 | optical thickness where to output the RT fields (Default: 0.) 48 | umu : float, array 49 | cosine of viewing zenith angle where to output the RT fields (Default: 1.) 50 | phi : float, array 51 | viewing azimuth angle where to output the RT fields (Default: 0.) 52 | maxmom : int 53 | Max. number of Legendre coefficients. (Default: 299) 54 | Nstr : int 55 | Number of computational polar angles to be used 56 | (= number of 'streams') ( should be even and .GE. 2 ). 57 | (Default: 32) 58 | temp : float, array 59 | LEV = 0 to NLYR, Temperatures (K) of levels. 60 | (Note that temperature is specified at LEVELS 61 | rather than for layers.) Be sure to put top level 62 | temperature in TEMPER(0), not TEMPER(1). Top and 63 | bottom level values do not need to agree with top and 64 | bottom boundary temperatures (i.e. temperature 65 | discontinuities are allowed). (Default: 300.) 66 | wvnmlo, wvnmhi : float 67 | Wavenumbers (inv cm) of spectral interval of interest 68 | ( used only for calculating Planck function ). 69 | Needed only if PLANK is TRUE, or in multiple runs, if 70 | LAMBER is FALSE and BDREF depends on spectral interval. 71 | (Default: wvnmlo=999., wvnmhi=1000.) 72 | UsrTau : logical 73 | = FALSE, Radiant quantities are to be returned 74 | at boundary of every computational layer. 75 | = TRUE, Radiant quantities are to be returned 76 | at user-specified optical depths 77 | (Default: True) 78 | UsrAng : logical 79 | = FALSE, Radiant quantities are to be returned 80 | at computational polar angles. 81 | = TRUE, Radiant quantities are to be returned 82 | at user-specified polar angles. 83 | (Default: True) 84 | ibcnd : int 85 | = 0, General case: boundary conditions any combination of: 86 | * beam illumination from the top ( see FBEAM ) 87 | * isotropic illumination from the top ( see FISOT ) 88 | * thermal emission from the top ( see TEMIS, TTEMP ) 89 | * internal thermal emission sources ( see TEMPER ) 90 | * reflection at the bottom ( see LAMBER, ALBEDO, BDREF ) 91 | * thermal emission from the bottom ( see BTEMP ) 92 | = 1, Return only albedo and transmissivity of the entire 93 | medium vs. incident beam angle; see S2 for details. 94 | (Default: 0) 95 | fisot : float 96 | Intensity of top-boundary isotropic illumination. 97 | [same units as PLKAVG (default W/sq m) if thermal 98 | sources active, otherwise arbitrary units]. 99 | Corresponding incident flux is pi (3.14159...) 100 | times FISOT. 101 | (Default: 0.) 102 | lamber : bool 103 | = TRUE, isotropically reflecting bottom boundary. 104 | = FALSE, bidirectionally reflecting bottom boundary. 105 | (Default: True) 106 | btemp : float 107 | Temperature of bottom boundary (K) (bottom emissivity 108 | is calculated from ALBEDO or function BDREF, so it need 109 | not be specified). Needed only if PLANK is TRUE. 110 | (Default: 300.) 111 | ttemp : float 112 | Temperature of top boundary (K). 113 | Needed only if PLANK is TRUE. 114 | (Default: 300.) 115 | temis : float 116 | Emissivity of top boundary. 117 | Needed only if PLANK is TRUE. 118 | (Default: 1.) 119 | plank : bool 120 | = TRUE, include thermal emission 121 | = FALSE, ignore all thermal emission (saves computer time) 122 | (Default: False) 123 | onlyFl : bool 124 | = TRUE, return fluxes, flux divergences, and mean 125 | intensities. 126 | = FALSE, return fluxes, flux divergences, mean 127 | intensities, AND intensities. 128 | (Default: False) 129 | accur : float 130 | Convergence criterion for azimuthal (Fourier cosine) 131 | series. Will stop when the following occurs twice: 132 | largest term being added is less than ACCUR times 133 | total series sum. (Twice because there are cases where 134 | terms are anomalously small but azimuthal series has 135 | not converged.) Should be between 0 and 0.01 to avoid 136 | risk of serious non-convergence. Has no effect on 137 | problems lacking a beam source, since azimuthal series 138 | has only one term in that case. 139 | (Default: 0.) 140 | PRNT : array(dtype=bool) 141 | Array of LOGICAL print flags causing the following prints 142 | L quantities printed 143 | -- ------------------ 144 | 1 input variables (except PMOM) 145 | 2 fluxes 146 | 3 intensities at user levels and angles 147 | 4 planar transmissivity and planar albedo 148 | as a function solar zenith angle ( IBCND = 1 ) 149 | 5 phase function moments PMOM for each layer 150 | ( only if PRNT(1) = TRUE, and only for layers 151 | with scattering ) 152 | (Default: array([False False False False False])) 153 | 154 | Returns 155 | ------- 156 | ds_fields : list of arrays 157 | [rfldir, rfldn, flup, dfdt, uavg, uu, albmed, trnmed] 158 | 159 | rfldir : Downward Direct 160 | rfldn : Downward Diffuse 161 | flup : Upward Diffuse 162 | dfdt : d(Net Flux) / d(Op Dep) 163 | uu : Intensity 164 | uavg : Mean intensity (including the direct beam) 165 | (Not corrected for delta-M-scaling effects) 166 | albmed : Albedo of the medium as a function of incident 167 | beam angle cosine UMU(IU) (IBCND = 1 case only) 168 | trnmed : Transmissivity of the medium as a function of incident 169 | beam angle cosine UMU(IU) (IBCND = 1 case only) 170 | 171 | Examples 172 | -------- 173 | >>> import disort 174 | >>> D_dir, D_diff, U_up, dFdt, I = disort.run(dTau, ssalb, iphas='Rayleigh') 175 | 176 | ## Examples 177 | 178 | See `test` directory. 179 | 180 | ## TODO 181 | 182 | - The current implementation have the following parameters hardcoded: 183 | 184 | - MXCLY = 50 (Max no. of computational layers) 185 | - MXULV = 50 (Max no. of output levels) 186 | - MXCMU = 48 (Max no. of computation polar angles) 187 | - MXUMU = 10 (Max no. of output polar angles) 188 | - MXPHI = 3 (Max no. of output azimuthal angles) 189 | - MXSQT = 1000 (Max no. of square roots of integers (for LEPOLY)) 190 | 191 | - These parameters are used as dimensions for array allocation. Allocation 192 | should be done dynamically 193 | -------------------------------------------------------------------------------- /Version: -------------------------------------------------------------------------------- 1 | 0.0.1 2 | 3 | -------------------------------------------------------------------------------- /_disort.pyf: -------------------------------------------------------------------------------- 1 | ! -*- f90 -*- 2 | ! Note: the context of this file is case sensitive. 3 | 4 | python module _disort ! in 5 | interface ! in :_disort 6 | function bdref(wvnmlo,wvnmhi,mu,mup,dphi) ! in :_disort:src/disort/src/BDREF.f 7 | real :: wvnmlo 8 | real :: wvnmhi 9 | real :: mu 10 | real :: mup 11 | real :: dphi 12 | real :: bdref 13 | end function bdref 14 | subroutine disort(nlyr,dtauc,ssalb,nmom,pmom,temper,wvnmlo,wvnmhi,usrtau,ntau,utau,nstr,usrang,numu,umu,nphi,phi,ibcnd,fbeam,umu0,phi0,fisot,lamber,albedo,btemp,ttemp,temis,plank,onlyfl,accur,prnt,header,maxcly,maxulv,maxumu,maxphi,maxmom,rfldir,rfldn,flup,dfdt,uavg,uu,albmed,trnmed) ! in :_disort:src/disort/src/DISORT.f 15 | integer :: nlyr 16 | real dimension(maxcly) :: dtauc 17 | real dimension(maxcly),depend(maxcly) :: ssalb 18 | integer :: nmom 19 | real dimension(maxmom + 1,maxcly),depend(maxcly) :: pmom 20 | real dimension(maxcly + 1),depend(maxcly) :: temper 21 | real :: wvnmlo 22 | real :: wvnmhi 23 | logical :: usrtau 24 | integer :: ntau 25 | real dimension(maxulv) :: utau 26 | integer :: nstr 27 | logical :: usrang 28 | integer :: numu 29 | real dimension(maxumu) :: umu 30 | integer :: nphi 31 | real dimension(maxphi) :: phi 32 | integer :: ibcnd 33 | real :: fbeam 34 | real :: umu0 35 | real :: phi0 36 | real :: fisot 37 | logical :: lamber 38 | real :: albedo 39 | real :: btemp 40 | real :: ttemp 41 | real :: temis 42 | logical :: plank 43 | logical :: onlyfl 44 | real :: accur 45 | logical dimension(5) :: prnt 46 | character*127 :: header 47 | integer, optional,check(len(dtauc)>=maxcly),depend(dtauc) :: maxcly=len(dtauc) 48 | integer, optional,check(len(utau)>=maxulv),depend(utau) :: maxulv=len(utau) 49 | integer, optional,check(len(umu)>=maxumu),depend(umu) :: maxumu=len(umu) 50 | integer, optional,check(len(phi)>=maxphi),depend(phi) :: maxphi=len(phi) 51 | integer, optional,check((shape(pmom,0)-1)==maxmom),depend(pmom) :: maxmom=(shape(pmom,0)-1) 52 | real dimension(maxulv),depend(maxulv) :: rfldir 53 | real dimension(maxulv),depend(maxulv) :: rfldn 54 | real dimension(maxulv),depend(maxulv) :: flup 55 | real dimension(maxulv),depend(maxulv) :: dfdt 56 | real dimension(maxulv),depend(maxulv) :: uavg 57 | real dimension(maxumu,maxulv,maxphi),depend(maxumu,maxulv,maxphi) :: uu 58 | real dimension(maxumu),depend(maxumu) :: albmed 59 | real dimension(maxumu),depend(maxumu) :: trnmed 60 | end subroutine disort 61 | subroutine asymtx(aa,evec,eval,m,ia,ievec,ier,wkd,aad,evecd,evald) ! in :_disort:src/disort/src/DISORT.f 62 | real dimension(ia,m) :: aa 63 | real dimension(ievec,m),depend(m) :: evec 64 | real dimension(m),depend(m) :: eval 65 | integer, optional,check(shape(aa,1)==m),depend(aa) :: m=shape(aa,1) 66 | integer, optional,check(shape(aa,0)==ia),depend(aa) :: ia=shape(aa,0) 67 | integer, optional,check(shape(evec,0)==ievec),depend(evec) :: ievec=shape(evec,0) 68 | integer :: ier 69 | double precision dimension(*) :: wkd 70 | double precision dimension(ia,m),depend(ia,m) :: aad 71 | double precision dimension(ia,m),depend(ia,m) :: evecd 72 | double precision dimension(m),depend(m) :: evald 73 | end subroutine asymtx 74 | subroutine cmpint(fbeam,gc,kk,layru,ll,lyrcut,mazim,mxcmu,mxulv,mxumu,ncut,nn,nstr,plank,ntau,taucpr,umu0,utaupr,zz,zplk0,zplk1,uum) ! in :_disort:src/disort/src/DISORT.f 75 | real :: fbeam 76 | real dimension(mxcmu,mxcmu,*) :: gc 77 | real dimension(mxcmu,*),depend(mxcmu) :: kk 78 | integer dimension(*) :: layru 79 | real dimension(mxcmu,*),depend(mxcmu) :: ll 80 | logical :: lyrcut 81 | integer :: mazim 82 | integer, optional,check(shape(gc,0)==mxcmu),depend(gc) :: mxcmu=shape(gc,0) 83 | integer, optional,check(len(utaupr)>=mxulv),depend(utaupr) :: mxulv=len(utaupr) 84 | integer, optional,check(shape(uum,0)==mxumu),depend(uum) :: mxumu=shape(uum,0) 85 | integer :: ncut 86 | integer :: nn 87 | integer :: nstr 88 | logical :: plank 89 | integer :: ntau 90 | real dimension(*) :: taucpr 91 | real :: umu0 92 | real dimension(mxulv) :: utaupr 93 | real dimension(mxcmu,*),depend(mxcmu) :: zz 94 | real dimension(mxcmu,*),depend(mxcmu) :: zplk0 95 | real dimension(mxcmu,*),depend(mxcmu) :: zplk1 96 | real dimension(mxumu,mxulv),depend(mxulv) :: uum 97 | end subroutine cmpint 98 | subroutine fluxes(cmu,cwt,fbeam,gc,kk,layru,ll,lyrcut,maxulv,mxcmu,mxulv,ncut,nn,nstr,ntau,pi,prnt,prntu0,ssalb,taucpr,umu0,utau,utaupr,xr0,xr1,zz,zplk0,zplk1,dfdt,flup,fldn,fldir,rfldir,rfldn,uavg,u0c) ! in :_disort:src/disort/src/DISORT.f 99 | real dimension(mxcmu) :: cmu 100 | real dimension(mxcmu),depend(mxcmu) :: cwt 101 | real :: fbeam 102 | real dimension(mxcmu,mxcmu,*),depend(mxcmu,mxcmu) :: gc 103 | real dimension(mxcmu,*),depend(mxcmu) :: kk 104 | integer dimension(mxulv) :: layru 105 | real dimension(mxcmu,*),depend(mxcmu) :: ll 106 | logical :: lyrcut 107 | integer, optional,check(len(utau)>=maxulv),depend(utau) :: maxulv=len(utau) 108 | integer, optional,check(len(cmu)>=mxcmu),depend(cmu) :: mxcmu=len(cmu) 109 | integer, optional,check(len(layru)>=mxulv),depend(layru) :: mxulv=len(layru) 110 | integer :: ncut 111 | integer :: nn 112 | integer :: nstr 113 | integer :: ntau 114 | real :: pi 115 | logical dimension(*) :: prnt 116 | logical :: prntu0 117 | real dimension(*) :: ssalb 118 | real dimension(*) :: taucpr 119 | real :: umu0 120 | real dimension(maxulv) :: utau 121 | real dimension(mxulv),depend(mxulv) :: utaupr 122 | real dimension(*) :: xr0 123 | real dimension(*) :: xr1 124 | real dimension(mxcmu,*),depend(mxcmu) :: zz 125 | real dimension(mxcmu,*),depend(mxcmu) :: zplk0 126 | real dimension(mxcmu,*),depend(mxcmu) :: zplk1 127 | real dimension(maxulv),depend(maxulv) :: dfdt 128 | real dimension(maxulv),depend(maxulv) :: flup 129 | real dimension(mxulv),depend(mxulv) :: fldn 130 | real dimension(mxulv),depend(mxulv) :: fldir 131 | real dimension(maxulv),depend(maxulv) :: rfldir 132 | real dimension(maxulv),depend(maxulv) :: rfldn 133 | real dimension(maxulv),depend(maxulv) :: uavg 134 | real dimension(mxcmu,mxulv),depend(mxcmu,mxulv) :: u0c 135 | end subroutine fluxes 136 | subroutine intcor(dither,fbeam,flyr,layru,lyrcut,maxmom,maxulv,maxumu,nmom,ncut,nphi,nstr,ntau,numu,oprim,phasa,phast,phasm,phirad,pi,rpd,pmom,ssalb,dtauc,tauc,taucpr,umu,umu0,utau,utaupr,uu) ! in :_disort:src/disort/src/DISORT.f 137 | real :: dither 138 | real :: fbeam 139 | real dimension(*) :: flyr 140 | integer dimension(*) :: layru 141 | logical :: lyrcut 142 | integer, optional,check((shape(pmom,0)-1)==maxmom),depend(pmom) :: maxmom=(shape(pmom,0)-1) 143 | integer, optional,check(shape(uu,1)==maxulv),depend(uu) :: maxulv=shape(uu,1) 144 | integer, optional,check(shape(uu,0)==maxumu),depend(uu) :: maxumu=shape(uu,0) 145 | integer :: nmom 146 | integer :: ncut 147 | integer :: nphi 148 | integer :: nstr 149 | integer :: ntau 150 | integer :: numu 151 | real dimension(*) :: oprim 152 | real dimension(*) :: phasa 153 | real dimension(*) :: phast 154 | real dimension(*) :: phasm 155 | real dimension(*) :: phirad 156 | real :: pi 157 | real :: rpd 158 | real dimension(maxmom + 1,*) :: pmom 159 | real dimension(*) :: ssalb 160 | real dimension(*) :: dtauc 161 | real dimension(*) :: tauc 162 | real dimension(*) :: taucpr 163 | real dimension(*) :: umu 164 | real :: umu0 165 | real dimension(*) :: utau 166 | real dimension(*) :: utaupr 167 | real dimension(maxumu,maxulv,*) :: uu 168 | end subroutine intcor 169 | function secsca(ctheta,flyr,layru,maxmom,nmom,nstr,pmom,ssalb,dtauc,tauc,umu,umu0,utau,fbeam,pi) ! in :_disort:src/disort/src/DISORT.f 170 | real :: ctheta 171 | real dimension(*) :: flyr 172 | integer :: layru 173 | integer, optional,check((shape(pmom,0)-1)==maxmom),depend(pmom) :: maxmom=(shape(pmom,0)-1) 174 | integer :: nmom 175 | integer :: nstr 176 | real dimension(maxmom + 1,*) :: pmom 177 | real dimension(*) :: ssalb 178 | real dimension(*) :: dtauc 179 | real dimension(*) :: tauc 180 | real :: umu 181 | real :: umu0 182 | real :: utau 183 | real :: fbeam 184 | real :: pi 185 | real :: secsca 186 | end function secsca 187 | subroutine setdis(cmu,cwt,deltam,dtauc,dtaucp,expbea,fbeam,flyr,gl,ibcnd,layru,lyrcut,maxmom,maxumu,mxcmu,ncut,nlyr,ntau,nn,nstr,plank,numu,onlyfl,corint,oprim,pmom,ssalb,tauc,taucpr,utau,utaupr,umu,umu0,usrtau,usrang) ! in :_disort:src/disort/src/DISORT.f 188 | real dimension(mxcmu) :: cmu 189 | real dimension(mxcmu),depend(mxcmu) :: cwt 190 | logical :: deltam 191 | real dimension(*) :: dtauc 192 | real dimension(*) :: dtaucp 193 | real dimension(*) :: expbea 194 | real :: fbeam 195 | real dimension(*) :: flyr 196 | real dimension(mxcmu + 1,*),depend(mxcmu) :: gl 197 | integer :: ibcnd 198 | integer dimension(*) :: layru 199 | logical :: lyrcut 200 | integer, optional,check((shape(pmom,0)-1)==maxmom),depend(pmom) :: maxmom=(shape(pmom,0)-1) 201 | integer, optional,check(len(umu)>=maxumu),depend(umu) :: maxumu=len(umu) 202 | integer, optional,check(len(cmu)>=mxcmu),depend(cmu) :: mxcmu=len(cmu) 203 | integer :: ncut 204 | integer :: nlyr 205 | integer :: ntau 206 | integer :: nn 207 | integer :: nstr 208 | logical :: plank 209 | integer :: numu 210 | logical :: onlyfl 211 | logical :: corint 212 | real dimension(*) :: oprim 213 | real dimension(maxmom + 1,*) :: pmom 214 | real dimension(*) :: ssalb 215 | real dimension(*) :: tauc 216 | real dimension(*) :: taucpr 217 | real dimension(*) :: utau 218 | real dimension(*) :: utaupr 219 | real dimension(maxumu) :: umu 220 | real :: umu0 221 | logical :: usrtau 222 | logical :: usrang 223 | end subroutine setdis 224 | subroutine setmtx(bdr,cband,cmu,cwt,delm0,dtaucp,gc,kk,lamber,lyrcut,mi,mi9m2,mxcmu,ncol,ncut,nnlyri,nn,nstr,taucpr,wk) ! in :_disort:src/disort/src/DISORT.f 225 | real dimension(mi,mi + 1) :: bdr 226 | real dimension(mi9m2,nnlyri) :: cband 227 | real dimension(mxcmu) :: cmu 228 | real dimension(mxcmu),depend(mxcmu) :: cwt 229 | real :: delm0 230 | real dimension(*) :: dtaucp 231 | real dimension(mxcmu,mxcmu,*),depend(mxcmu,mxcmu) :: gc 232 | real dimension(mxcmu,*),depend(mxcmu) :: kk 233 | logical :: lamber 234 | logical :: lyrcut 235 | integer, optional,check(shape(bdr,0)==mi),depend(bdr) :: mi=shape(bdr,0) 236 | integer, optional,check(shape(cband,0)==mi9m2),depend(cband) :: mi9m2=shape(cband,0) 237 | integer, optional,check(len(cmu)>=mxcmu),depend(cmu) :: mxcmu=len(cmu) 238 | integer :: ncol 239 | integer :: ncut 240 | integer, optional,check(shape(cband,1)==nnlyri),depend(cband) :: nnlyri=shape(cband,1) 241 | integer :: nn 242 | integer :: nstr 243 | real dimension(*) :: taucpr 244 | real dimension(mxcmu),depend(mxcmu) :: wk 245 | end subroutine setmtx 246 | function sinsca(dither,layru,nlyr,phase,omega,tau,umu,umu0,utau,fbeam,pi) ! in :_disort:src/disort/src/DISORT.f 247 | real :: dither 248 | integer :: layru 249 | integer :: nlyr 250 | real dimension(*) :: phase 251 | real dimension(*) :: omega 252 | real dimension(*) :: tau 253 | real :: umu 254 | real :: umu0 255 | real :: utau 256 | real :: fbeam 257 | real :: pi 258 | real :: sinsca 259 | end function sinsca 260 | subroutine soleig(amb,apb,array,cmu,cwt,gl,mi,mazim,mxcmu,nn,nstr,ylmc,cc,evecc,eval,kk,gc,aad,eveccd,evald,wkd) ! in :_disort:src/disort/src/DISORT.f 261 | real dimension(mi,mi) :: amb 262 | real dimension(mi,mi),depend(mi,mi) :: apb 263 | real dimension(mi,*),depend(mi) :: array 264 | real dimension(mxcmu) :: cmu 265 | real dimension(mxcmu),depend(mxcmu) :: cwt 266 | real dimension(mxcmu + 1),depend(mxcmu) :: gl 267 | integer, optional,check(shape(amb,0)==mi),depend(amb) :: mi=shape(amb,0) 268 | integer :: mazim 269 | integer, optional,check(len(cmu)>=mxcmu),depend(cmu) :: mxcmu=len(cmu) 270 | integer :: nn 271 | integer :: nstr 272 | real dimension(mxcmu + 1,mxcmu),depend(mxcmu,mxcmu) :: ylmc 273 | real dimension(mxcmu,mxcmu),depend(mxcmu,mxcmu) :: cc 274 | real dimension(mxcmu,mxcmu),depend(mxcmu,mxcmu) :: evecc 275 | real dimension(mi),depend(mi) :: eval 276 | real dimension(mxcmu),depend(mxcmu) :: kk 277 | real dimension(mxcmu,mxcmu),depend(mxcmu,mxcmu) :: gc 278 | double precision dimension(mi,mi),depend(mi,mi) :: aad 279 | double precision dimension(mi,mi),depend(mi,mi) :: eveccd 280 | double precision dimension(mi),depend(mi) :: evald 281 | double precision dimension(mxcmu),depend(mxcmu) :: wkd 282 | end subroutine soleig 283 | subroutine solve0(b,bdr,bem,bplank,cband,cmu,cwt,expbea,fbeam,fisot,ipvt,lamber,ll,lyrcut,mazim,mi,mi9m2,mxcmu,ncol,ncut,nn,nstr,nnlyri,pi,tplank,taucpr,umu0,z,zz,zplk0,zplk1) ! in :_disort:src/disort/src/DISORT.f 284 | real dimension(nnlyri) :: b 285 | real dimension(mi,mi + 1) :: bdr 286 | real dimension(mi),depend(mi) :: bem 287 | real :: bplank 288 | real dimension(mi9m2,nnlyri),depend(nnlyri) :: cband 289 | real dimension(mxcmu) :: cmu 290 | real dimension(mxcmu),depend(mxcmu) :: cwt 291 | real dimension(*) :: expbea 292 | real :: fbeam 293 | real :: fisot 294 | integer dimension(*) :: ipvt 295 | logical :: lamber 296 | real dimension(mxcmu,*),depend(mxcmu) :: ll 297 | logical :: lyrcut 298 | integer :: mazim 299 | integer, optional,check(shape(bdr,0)==mi),depend(bdr) :: mi=shape(bdr,0) 300 | integer, optional,check(shape(cband,0)==mi9m2),depend(cband) :: mi9m2=shape(cband,0) 301 | integer, optional,check(len(cmu)>=mxcmu),depend(cmu) :: mxcmu=len(cmu) 302 | integer :: ncol 303 | integer :: ncut 304 | integer :: nn 305 | integer :: nstr 306 | integer, optional,check(len(b)>=nnlyri),depend(b) :: nnlyri=len(b) 307 | real :: pi 308 | real :: tplank 309 | real dimension(*) :: taucpr 310 | real :: umu0 311 | real dimension(nnlyri),depend(nnlyri) :: z 312 | real dimension(mxcmu,*),depend(mxcmu) :: zz 313 | real dimension(mxcmu,*),depend(mxcmu) :: zplk0 314 | real dimension(mxcmu,*),depend(mxcmu) :: zplk1 315 | end subroutine solve0 316 | subroutine surfac(albedo,delm0,cmu,fbeam,lamber,mi,mazim,mxumu,nn,numu,onlyfl,pi,umu,umu0,usrang,wvnmlo,wvnmhi,bdr,emu,bem,rmu) ! in :_disort:src/disort/src/DISORT.f 317 | real :: albedo 318 | real :: delm0 319 | real dimension(*) :: cmu 320 | real :: fbeam 321 | logical :: lamber 322 | integer, optional,check(shape(bdr,0)==mi),depend(bdr) :: mi=shape(bdr,0) 323 | integer :: mazim 324 | integer, optional,check(len(emu)>=mxumu),depend(emu) :: mxumu=len(emu) 325 | integer :: nn 326 | integer :: numu 327 | logical :: onlyfl 328 | real :: pi 329 | real dimension(*) :: umu 330 | real :: umu0 331 | logical :: usrang 332 | real :: wvnmlo 333 | real :: wvnmhi 334 | real dimension(mi,mi + 1) :: bdr 335 | real dimension(mxumu) :: emu 336 | real dimension(mi),depend(mi) :: bem 337 | real dimension(mxumu,mi + 1),depend(mxumu,mi) :: rmu 338 | end subroutine surfac 339 | subroutine terpev(cwt,evecc,gl,gu,mazim,mxcmu,mxumu,nn,nstr,numu,wk,ylmc,ylmu) ! in :_disort:src/disort/src/DISORT.f 340 | real dimension(mxcmu) :: cwt 341 | real dimension(mxcmu,mxcmu),depend(mxcmu,mxcmu) :: evecc 342 | real dimension(mxcmu + 1),depend(mxcmu) :: gl 343 | real dimension(mxumu,mxcmu),depend(mxcmu) :: gu 344 | integer :: mazim 345 | integer, optional,check(len(cwt)>=mxcmu),depend(cwt) :: mxcmu=len(cwt) 346 | integer, optional,check(shape(gu,0)==mxumu),depend(gu) :: mxumu=shape(gu,0) 347 | integer :: nn 348 | integer :: nstr 349 | integer :: numu 350 | real dimension(mxcmu),depend(mxcmu) :: wk 351 | real dimension(mxcmu + 1,mxcmu),depend(mxcmu,mxcmu) :: ylmc 352 | real dimension(mxcmu + 1,mxumu),depend(mxcmu,mxumu) :: ylmu 353 | end subroutine terpev 354 | subroutine terpso(cwt,delm0,fbeam,gl,mazim,mxcmu,plank,numu,nstr,oprim,pi,ylm0,ylmc,ylmu,psi0,psi1,xr0,xr1,z0,z1,zj,zbeam,z0u,z1u) ! in :_disort:src/disort/src/DISORT.f 355 | real dimension(mxcmu) :: cwt 356 | real :: delm0 357 | real :: fbeam 358 | real dimension(mxcmu + 1),depend(mxcmu) :: gl 359 | integer :: mazim 360 | integer, optional,check(len(cwt)>=mxcmu),depend(cwt) :: mxcmu=len(cwt) 361 | logical :: plank 362 | integer :: numu 363 | integer :: nstr 364 | real :: oprim 365 | real :: pi 366 | real dimension(mxcmu + 1),depend(mxcmu) :: ylm0 367 | real dimension(mxcmu + 1,mxcmu),depend(mxcmu,mxcmu) :: ylmc 368 | real dimension(mxcmu + 1,*),depend(mxcmu) :: ylmu 369 | real dimension(mxcmu),depend(mxcmu) :: psi0 370 | real dimension(mxcmu),depend(mxcmu) :: psi1 371 | real :: xr0 372 | real :: xr1 373 | real dimension(mxcmu),depend(mxcmu) :: z0 374 | real dimension(mxcmu),depend(mxcmu) :: z1 375 | real dimension(mxcmu),depend(mxcmu) :: zj 376 | real dimension(*) :: zbeam 377 | real dimension(*) :: z0u 378 | real dimension(*) :: z1u 379 | end subroutine terpso 380 | subroutine upbeam(array,cc,cmu,delm0,fbeam,gl,ipvt,mazim,mxcmu,nn,nstr,pi,umu0,wk,ylm0,ylmc,zj,zz) ! in :_disort:src/disort/src/DISORT.f 381 | real dimension(mxcmu,mxcmu) :: array 382 | real dimension(mxcmu,mxcmu),depend(mxcmu,mxcmu) :: cc 383 | real dimension(mxcmu),depend(mxcmu) :: cmu 384 | real :: delm0 385 | real :: fbeam 386 | real dimension(mxcmu + 1),depend(mxcmu) :: gl 387 | integer dimension(*) :: ipvt 388 | integer :: mazim 389 | integer, optional,check(shape(array,0)==mxcmu),depend(array) :: mxcmu=shape(array,0) 390 | integer :: nn 391 | integer :: nstr 392 | real :: pi 393 | real :: umu0 394 | real dimension(mxcmu),depend(mxcmu) :: wk 395 | real dimension(mxcmu + 1),depend(mxcmu) :: ylm0 396 | real dimension(mxcmu + 1,*),depend(mxcmu) :: ylmc 397 | real dimension(mxcmu),depend(mxcmu) :: zj 398 | real dimension(mxcmu),depend(mxcmu) :: zz 399 | end subroutine upbeam 400 | subroutine upisot(array,cc,cmu,ipvt,mxcmu,nn,nstr,oprim,wk,xr0,xr1,z0,z1,zplk0,zplk1) ! in :_disort:src/disort/src/DISORT.f 401 | real dimension(mxcmu,mxcmu) :: array 402 | real dimension(mxcmu,mxcmu),depend(mxcmu,mxcmu) :: cc 403 | real dimension(mxcmu),depend(mxcmu) :: cmu 404 | integer dimension(*) :: ipvt 405 | integer, optional,check(shape(array,0)==mxcmu),depend(array) :: mxcmu=shape(array,0) 406 | integer :: nn 407 | integer :: nstr 408 | real :: oprim 409 | real dimension(mxcmu),depend(mxcmu) :: wk 410 | real :: xr0 411 | real :: xr1 412 | real dimension(mxcmu),depend(mxcmu) :: z0 413 | real dimension(mxcmu),depend(mxcmu) :: z1 414 | real dimension(mxcmu),depend(mxcmu) :: zplk0 415 | real dimension(mxcmu),depend(mxcmu) :: zplk1 416 | end subroutine upisot 417 | subroutine usrint(bplank,cmu,cwt,delm0,dtaucp,emu,expbea,fbeam,fisot,gc,gu,kk,lamber,layru,ll,lyrcut,mazim,mxcmu,mxulv,mxumu,ncut,nlyr,nn,nstr,plank,numu,ntau,pi,rmu,taucpr,tplank,umu,umu0,utaupr,wk,zbeam,z0u,z1u,zz,zplk0,zplk1,uum) ! in :_disort:src/disort/src/DISORT.f 418 | real :: bplank 419 | real dimension(mxcmu) :: cmu 420 | real dimension(mxcmu),depend(mxcmu) :: cwt 421 | real :: delm0 422 | real dimension(*) :: dtaucp 423 | real dimension(mxumu) :: emu 424 | real dimension(*) :: expbea 425 | real :: fbeam 426 | real :: fisot 427 | real dimension(mxcmu,mxcmu,*),depend(mxcmu,mxcmu) :: gc 428 | real dimension(mxumu,mxcmu,*),depend(mxumu,mxcmu) :: gu 429 | real dimension(mxcmu,*),depend(mxcmu) :: kk 430 | logical :: lamber 431 | integer dimension(*) :: layru 432 | real dimension(mxcmu,*),depend(mxcmu) :: ll 433 | logical :: lyrcut 434 | integer :: mazim 435 | integer, optional,check(len(cmu)>=mxcmu),depend(cmu) :: mxcmu=len(cmu) 436 | integer, optional,check(len(utaupr)>=mxulv),depend(utaupr) :: mxulv=len(utaupr) 437 | integer, optional,check(len(emu)>=mxumu),depend(emu) :: mxumu=len(emu) 438 | integer :: ncut 439 | integer :: nlyr 440 | integer :: nn 441 | integer :: nstr 442 | logical :: plank 443 | integer :: numu 444 | integer :: ntau 445 | real :: pi 446 | real dimension(mxumu,*),depend(mxumu) :: rmu 447 | real dimension(*) :: taucpr 448 | real :: tplank 449 | real dimension(*) :: umu 450 | real :: umu0 451 | real dimension(mxulv) :: utaupr 452 | real dimension(mxcmu),depend(mxcmu) :: wk 453 | real dimension(mxumu,*),depend(mxumu) :: zbeam 454 | real dimension(mxumu,*),depend(mxumu) :: z0u 455 | real dimension(mxumu,*),depend(mxumu) :: z1u 456 | real dimension(mxcmu,*),depend(mxcmu) :: zz 457 | real dimension(mxcmu,*),depend(mxcmu) :: zplk0 458 | real dimension(mxcmu,*),depend(mxcmu) :: zplk1 459 | real dimension(mxumu,mxulv),depend(mxumu,mxulv) :: uum 460 | end subroutine usrint 461 | function xifunc(umu1,umu2,umu3,tau) ! in :_disort:src/disort/src/DISORT.f 462 | real :: umu1 463 | real :: umu2 464 | real :: umu3 465 | real :: tau 466 | real :: xifunc 467 | end function xifunc 468 | subroutine chekin(nlyr,dtauc,ssalb,nmom,pmom,temper,wvnmlo,wvnmhi,usrtau,ntau,utau,nstr,usrang,numu,umu,nphi,phi,ibcnd,fbeam,umu0,phi0,fisot,lamber,albedo,btemp,ttemp,temis,plank,onlyfl,deltam,corint,accur,tauc,maxcly,maxulv,maxumu,maxphi,maxmom,mxcly,mxulv,mxumu,mxcmu,mxphi,mxsqt) ! in :_disort:src/disort/src/DISORT.f 469 | integer :: nlyr 470 | real dimension(maxcly) :: dtauc 471 | real dimension(maxcly),depend(maxcly) :: ssalb 472 | integer :: nmom 473 | real dimension(maxmom + 1,maxcly),depend(maxcly) :: pmom 474 | real dimension(maxcly + 1),depend(maxcly) :: temper 475 | real :: wvnmlo 476 | real :: wvnmhi 477 | logical :: usrtau 478 | integer :: ntau 479 | real dimension(maxulv) :: utau 480 | integer :: nstr 481 | logical :: usrang 482 | integer :: numu 483 | real dimension(maxumu) :: umu 484 | integer :: nphi 485 | real dimension(maxphi) :: phi 486 | integer :: ibcnd 487 | real :: fbeam 488 | real :: umu0 489 | real :: phi0 490 | real :: fisot 491 | logical :: lamber 492 | real :: albedo 493 | real :: btemp 494 | real :: ttemp 495 | real :: temis 496 | logical :: plank 497 | logical :: onlyfl 498 | logical :: deltam 499 | logical :: corint 500 | real :: accur 501 | real dimension(mxcly + 1) :: tauc 502 | integer, optional,check(len(dtauc)>=maxcly),depend(dtauc) :: maxcly=len(dtauc) 503 | integer, optional,check(len(utau)>=maxulv),depend(utau) :: maxulv=len(utau) 504 | integer, optional,check(len(umu)>=maxumu),depend(umu) :: maxumu=len(umu) 505 | integer, optional,check(len(phi)>=maxphi),depend(phi) :: maxphi=len(phi) 506 | integer, optional,check((shape(pmom,0)-1)==maxmom),depend(pmom) :: maxmom=(shape(pmom,0)-1) 507 | integer, optional,check((len(tauc)-1)>=mxcly),depend(tauc) :: mxcly=(len(tauc)-1) 508 | integer :: mxulv 509 | integer :: mxumu 510 | integer :: mxcmu 511 | integer :: mxphi 512 | integer :: mxsqt 513 | end subroutine chekin 514 | function dref(wvnmlo,wvnmhi,mu) ! in :_disort:src/disort/src/DISORT.f 515 | real :: wvnmlo 516 | real :: wvnmhi 517 | real :: mu 518 | real :: dref 519 | end function dref 520 | subroutine lepoly(nmu,m,maxmu,twonm1,mu,sqt,ylm) ! in :_disort:src/disort/src/DISORT.f 521 | integer :: nmu 522 | integer :: m 523 | integer, optional,check((shape(ylm,0)-1)==maxmu),depend(ylm) :: maxmu=(shape(ylm,0)-1) 524 | integer :: twonm1 525 | real dimension(*) :: mu 526 | real dimension(*) :: sqt 527 | real dimension(maxmu + 1,*) :: ylm 528 | end subroutine lepoly 529 | function plkavg(wnumlo,wnumhi,t) ! in :_disort:src/disort/src/DISORT.f 530 | real :: wnumlo 531 | real :: wnumhi 532 | real :: t 533 | real :: plkavg 534 | end function plkavg 535 | subroutine pravin(umu,numu,mxumu,utau,ntau,u0u) ! in :_disort:src/disort/src/DISORT.f 536 | real dimension(numu) :: umu 537 | integer, optional,check(len(umu)>=numu),depend(umu) :: numu=len(umu) 538 | integer, optional,check(shape(u0u,0)==mxumu),depend(u0u) :: mxumu=shape(u0u,0) 539 | real dimension(ntau) :: utau 540 | integer, optional,check(len(utau)>=ntau),depend(utau) :: ntau=len(utau) 541 | real dimension(mxumu,*) :: u0u 542 | end subroutine pravin 543 | subroutine prtinp(nlyr,dtauc,dtaucp,ssalb,nmom,pmom,temper,wvnmlo,wvnmhi,ntau,utau,nstr,numu,umu,nphi,phi,ibcnd,fbeam,umu0,phi0,fisot,lamber,albedo,btemp,ttemp,temis,deltam,plank,onlyfl,corint,accur,flyr,lyrcut,oprim,tauc,taucpr,maxmom,prtmom) ! in :_disort:src/disort/src/DISORT.f 544 | integer :: nlyr 545 | real dimension(*) :: dtauc 546 | real dimension(*) :: dtaucp 547 | real dimension(*) :: ssalb 548 | integer :: nmom 549 | real dimension(maxmom + 1,*) :: pmom 550 | real dimension(*) :: temper 551 | real :: wvnmlo 552 | real :: wvnmhi 553 | integer :: ntau 554 | real dimension(*) :: utau 555 | integer :: nstr 556 | integer :: numu 557 | real dimension(*) :: umu 558 | integer :: nphi 559 | real dimension(*) :: phi 560 | integer :: ibcnd 561 | real :: fbeam 562 | real :: umu0 563 | real :: phi0 564 | real :: fisot 565 | logical :: lamber 566 | real :: albedo 567 | real :: btemp 568 | real :: ttemp 569 | real :: temis 570 | logical :: deltam 571 | logical :: plank 572 | logical :: onlyfl 573 | logical :: corint 574 | real :: accur 575 | real dimension(*) :: flyr 576 | logical :: lyrcut 577 | real dimension(*) :: oprim 578 | real dimension(*) :: tauc 579 | real dimension(*) :: taucpr 580 | integer, optional,check((shape(pmom,0)-1)==maxmom),depend(pmom) :: maxmom=(shape(pmom,0)-1) 581 | logical :: prtmom 582 | end subroutine prtinp 583 | subroutine prtint(uu,utau,ntau,umu,numu,phi,nphi,maxulv,maxumu) ! in :_disort:src/disort/src/DISORT.f 584 | real dimension(maxumu,maxulv,*) :: uu 585 | real dimension(*) :: utau 586 | integer :: ntau 587 | real dimension(*) :: umu 588 | integer :: numu 589 | real dimension(*) :: phi 590 | integer :: nphi 591 | integer, optional,check(shape(uu,1)==maxulv),depend(uu) :: maxulv=shape(uu,1) 592 | integer, optional,check(shape(uu,0)==maxumu),depend(uu) :: maxumu=shape(uu,0) 593 | end subroutine prtint 594 | subroutine qgausn(m,gmu,gwt) ! in :_disort:src/disort/src/DISORT.f 595 | integer, optional,check(len(gmu)>=m),depend(gmu) :: m=len(gmu) 596 | real dimension(m) :: gmu 597 | real dimension(m),depend(m) :: gwt 598 | end subroutine qgausn 599 | function ratio(a,b) ! in :_disort:src/disort/src/DISORT.f 600 | real :: a 601 | real :: b 602 | real :: ratio 603 | end function ratio 604 | subroutine slftst(corint,accur,albedo,btemp,deltam,dtauc,fbeam,fisot,ibcnd,lamber,nlyr,plank,nphi,numu,nstr,ntau,onlyfl,phi,phi0,nmom,pmom,prnt,prntu0,ssalb,temis,temper,ttemp,umu,usrang,usrtau,utau,umu0,wvnmhi,wvnmlo,compar,flup,rfldir,rfldn,uu) ! in :_disort:src/disort/src/DISORT.f 605 | logical :: corint 606 | real :: accur 607 | real :: albedo 608 | real :: btemp 609 | logical :: deltam 610 | real :: dtauc 611 | real :: fbeam 612 | real :: fisot 613 | integer :: ibcnd 614 | logical :: lamber 615 | integer :: nlyr 616 | logical :: plank 617 | integer :: nphi 618 | integer :: numu 619 | integer :: nstr 620 | integer :: ntau 621 | logical :: onlyfl 622 | real :: phi 623 | real :: phi0 624 | integer :: nmom 625 | real dimension(*) :: pmom 626 | logical dimension(*) :: prnt 627 | logical dimension(*) :: prntu0 628 | real :: ssalb 629 | real :: temis 630 | real dimension(*) :: temper 631 | real :: ttemp 632 | real :: umu 633 | logical :: usrang 634 | logical :: usrtau 635 | real :: utau 636 | real :: umu0 637 | real :: wvnmhi 638 | real :: wvnmlo 639 | logical :: compar 640 | real :: flup 641 | real :: rfldir 642 | real :: rfldn 643 | real :: uu 644 | end subroutine slftst 645 | subroutine zeroal(nd1,expbea,flyr,oprim,phasa,phast,phasm,taucpr,xr0,xr1,nd2,cmu,cwt,psi0,psi1,wk,z0,z1,zj,nd3,ylm0,nd4,array,cc,evecc,nd5,gl,nd6,ylmc,nd7,ylmu,nd8,kk,ll,zz,zplk0,zplk1,nd9,gc,nd10,layru,utaupr,nd11,gu,nd12,z0u,z1u,zbeam,nd13,eval,nd14,amb,apb,nd15,ipvt,z,nd16,rfldir,rfldn,flup,uavg,dfdt,nd17,albmed,trnmed,nd18,u0u,nd19,uu) ! in :_disort:src/disort/src/DISORT.f 646 | integer :: nd1 647 | real dimension(*) :: expbea 648 | real dimension(*) :: flyr 649 | real dimension(*) :: oprim 650 | real dimension(*) :: phasa 651 | real dimension(*) :: phast 652 | real dimension(*) :: phasm 653 | real dimension(*) :: taucpr 654 | real dimension(*) :: xr0 655 | real dimension(*) :: xr1 656 | integer :: nd2 657 | real dimension(*) :: cmu 658 | real dimension(*) :: cwt 659 | real dimension(*) :: psi0 660 | real dimension(*) :: psi1 661 | real dimension(*) :: wk 662 | real dimension(*) :: z0 663 | real dimension(*) :: z1 664 | real dimension(*) :: zj 665 | integer :: nd3 666 | real dimension(*) :: ylm0 667 | integer :: nd4 668 | real dimension(*) :: array 669 | real dimension(*) :: cc 670 | real dimension(*) :: evecc 671 | integer :: nd5 672 | real dimension(*) :: gl 673 | integer :: nd6 674 | real dimension(*) :: ylmc 675 | integer :: nd7 676 | real dimension(*) :: ylmu 677 | integer :: nd8 678 | real dimension(*) :: kk 679 | real dimension(*) :: ll 680 | real dimension(*) :: zz 681 | real dimension(*) :: zplk0 682 | real dimension(*) :: zplk1 683 | integer :: nd9 684 | real dimension(*) :: gc 685 | integer :: nd10 686 | integer dimension(*) :: layru 687 | real dimension(*) :: utaupr 688 | integer :: nd11 689 | real dimension(*) :: gu 690 | integer :: nd12 691 | real dimension(*) :: z0u 692 | real dimension(*) :: z1u 693 | real dimension(*) :: zbeam 694 | integer :: nd13 695 | real dimension(*) :: eval 696 | integer :: nd14 697 | real dimension(*) :: amb 698 | real dimension(*) :: apb 699 | integer :: nd15 700 | integer dimension(*) :: ipvt 701 | real dimension(*) :: z 702 | integer :: nd16 703 | real dimension(*) :: rfldir 704 | real dimension(*) :: rfldn 705 | real dimension(*) :: flup 706 | real dimension(*) :: uavg 707 | real dimension(*) :: dfdt 708 | integer :: nd17 709 | real dimension(*) :: albmed 710 | real dimension(*) :: trnmed 711 | integer :: nd18 712 | real dimension(*) :: u0u 713 | integer :: nd19 714 | real dimension(*) :: uu 715 | end subroutine zeroal 716 | subroutine zeroit(a,length) ! in :_disort:src/disort/src/DISORT.f 717 | real dimension(length) :: a 718 | integer, optional,check(len(a)>=length),depend(a) :: length=len(a) 719 | end subroutine zeroit 720 | subroutine albtrn(albedo,amb,apb,array,b,bdr,cband,cc,cmu,cwt,dtaucp,eval,evecc,gl,gc,gu,ipvt,kk,ll,nlyr,nn,nstr,numu,prnt,taucpr,umu,u0u,wk,ylmc,ylmu,z,aad,evald,eveccd,wkd,mi,mi9m2,maxumu,mxcmu,mxumu,nnlyri,sqt,albmed,trnmed) ! in :_disort:src/disort/src/DISORT.f 721 | real :: albedo 722 | real dimension(mi,mi) :: amb 723 | real dimension(mi,mi),depend(mi,mi) :: apb 724 | real dimension(mxcmu,mxcmu) :: array 725 | real dimension(nnlyri) :: b 726 | real dimension(mi,mi + 1),depend(mi,mi) :: bdr 727 | real dimension(mi9m2,nnlyri),depend(nnlyri) :: cband 728 | real dimension(mxcmu,mxcmu),depend(mxcmu,mxcmu) :: cc 729 | real dimension(mxcmu),depend(mxcmu) :: cmu 730 | real dimension(mxcmu),depend(mxcmu) :: cwt 731 | real dimension(*) :: dtaucp 732 | real dimension(mi),depend(mi) :: eval 733 | real dimension(mxcmu,mxcmu),depend(mxcmu,mxcmu) :: evecc 734 | real dimension(mxcmu + 1,*),depend(mxcmu) :: gl 735 | real dimension(mxcmu,mxcmu,*),depend(mxcmu,mxcmu) :: gc 736 | real dimension(mxumu,mxcmu,*),depend(mxcmu) :: gu 737 | integer dimension(*) :: ipvt 738 | real dimension(mxcmu,*),depend(mxcmu) :: kk 739 | real dimension(mxcmu,*),depend(mxcmu) :: ll 740 | integer :: nlyr 741 | integer :: nn 742 | integer :: nstr 743 | integer :: numu 744 | logical dimension(*) :: prnt 745 | real dimension(*) :: taucpr 746 | real dimension(maxumu) :: umu 747 | real dimension(mxumu,*),depend(mxumu) :: u0u 748 | real dimension(mxcmu),depend(mxcmu) :: wk 749 | real dimension(mxcmu + 1,mxcmu),depend(mxcmu,mxcmu) :: ylmc 750 | real dimension(mxcmu + 1,*),depend(mxcmu) :: ylmu 751 | real dimension(nnlyri),depend(nnlyri) :: z 752 | double precision dimension(mi,mi),depend(mi,mi) :: aad 753 | double precision dimension(mi),depend(mi) :: evald 754 | double precision dimension(mi,mi),depend(mi,mi) :: eveccd 755 | double precision dimension(mxcmu),depend(mxcmu) :: wkd 756 | integer, optional,check(shape(amb,0)==mi),depend(amb) :: mi=shape(amb,0) 757 | integer, optional,check(shape(cband,0)==mi9m2),depend(cband) :: mi9m2=shape(cband,0) 758 | integer, optional,check(len(umu)>=maxumu),depend(umu) :: maxumu=len(umu) 759 | integer, optional,check(shape(array,0)==mxcmu),depend(array) :: mxcmu=shape(array,0) 760 | integer, optional,check(shape(gu,0)==mxumu),depend(gu) :: mxumu=shape(gu,0) 761 | integer, optional,check(len(b)>=nnlyri),depend(b) :: nnlyri=len(b) 762 | real dimension(*) :: sqt 763 | real dimension(maxumu),depend(maxumu) :: albmed 764 | real dimension(maxumu),depend(maxumu) :: trnmed 765 | end subroutine albtrn 766 | subroutine altrin(gu,kk,ll,mxcmu,mxumu,maxumu,nlyr,nn,nstr,numu,taucpr,umu,u0u,wk) ! in :_disort:src/disort/src/DISORT.f 767 | real dimension(mxumu,mxcmu,*) :: gu 768 | real dimension(mxcmu,*),depend(mxcmu) :: kk 769 | real dimension(mxcmu,*),depend(mxcmu) :: ll 770 | integer, optional,check(shape(gu,1)==mxcmu),depend(gu) :: mxcmu=shape(gu,1) 771 | integer, optional,check(shape(gu,0)==mxumu),depend(gu) :: mxumu=shape(gu,0) 772 | integer, optional,check(len(umu)>=maxumu),depend(umu) :: maxumu=len(umu) 773 | integer :: nlyr 774 | integer :: nn 775 | integer :: nstr 776 | integer :: numu 777 | real dimension(*) :: taucpr 778 | real dimension(maxumu) :: umu 779 | real dimension(mxumu,*),depend(mxumu) :: u0u 780 | real dimension(mxcmu),depend(mxcmu) :: wk 781 | end subroutine altrin 782 | subroutine praltr(umu,numu,albmed,trnmed) ! in :_disort:src/disort/src/DISORT.f 783 | real dimension(numu) :: umu 784 | integer, optional,check(len(umu)>=numu),depend(umu) :: numu=len(umu) 785 | real dimension(numu),depend(numu) :: albmed 786 | real dimension(numu),depend(numu) :: trnmed 787 | end subroutine praltr 788 | subroutine solve1(b,cband,fisot,ihom,ipvt,ll,mi9m2,mxcmu,ncol,ncut,nn,nnlyri,nstr) ! in :_disort:src/disort/src/DISORT.f 789 | real dimension(nnlyri) :: b 790 | real dimension(mi9m2,nnlyri),depend(nnlyri) :: cband 791 | real :: fisot 792 | integer :: ihom 793 | integer dimension(nnlyri),depend(nnlyri) :: ipvt 794 | real dimension(mxcmu,*) :: ll 795 | integer, optional,check(shape(cband,0)==mi9m2),depend(cband) :: mi9m2=shape(cband,0) 796 | integer, optional,check(shape(ll,0)==mxcmu),depend(ll) :: mxcmu=shape(ll,0) 797 | integer :: ncol 798 | integer :: ncut 799 | integer :: nn 800 | integer, optional,check(len(b)>=nnlyri),depend(b) :: nnlyri=len(b) 801 | integer :: nstr 802 | end subroutine solve1 803 | subroutine spaltr(cmu,cwt,gc,kk,ll,mxcmu,nlyr,nn,nstr,taucpr,sflup,sfldn) ! in :_disort:src/disort/src/DISORT.f 804 | real dimension(mxcmu) :: cmu 805 | real dimension(mxcmu),depend(mxcmu) :: cwt 806 | real dimension(mxcmu,mxcmu,*),depend(mxcmu,mxcmu) :: gc 807 | real dimension(mxcmu,*),depend(mxcmu) :: kk 808 | real dimension(mxcmu,*),depend(mxcmu) :: ll 809 | integer, optional,check(len(cmu)>=mxcmu),depend(cmu) :: mxcmu=len(cmu) 810 | integer :: nlyr 811 | integer :: nn 812 | integer :: nstr 813 | real dimension(*) :: taucpr 814 | real :: sflup 815 | real :: sfldn 816 | end subroutine spaltr 817 | subroutine errmsg(messag,fatal) ! in :_disort:src/disort/src/ErrPack.f 818 | character*(*) :: messag 819 | logical :: fatal 820 | end subroutine errmsg 821 | function wrtbad(varnam) ! in :_disort:src/disort/src/ErrPack.f 822 | character*(*) :: varnam 823 | logical :: wrtbad 824 | end function wrtbad 825 | function wrtdim(dimnam,minval) ! in :_disort:src/disort/src/ErrPack.f 826 | character*(*) :: dimnam 827 | integer :: minval 828 | logical :: wrtdim 829 | end function wrtdim 830 | function tstbad(varnam,relerr) ! in :_disort:src/disort/src/ErrPack.f 831 | character*(*) :: varnam 832 | real :: relerr 833 | logical :: tstbad 834 | end function tstbad 835 | subroutine getmom(iphas,gg,nmom,pmom) ! in :_disort:src/disort/src/GETMOM.f 836 | integer :: iphas 837 | real :: gg 838 | integer, optional,check((len(pmom)-1)>=nmom),depend(pmom) :: nmom=(len(pmom)-1) 839 | real dimension(nmom + 1) :: pmom 840 | end subroutine getmom 841 | subroutine sgbco(abd,lda,n,ml,mu,ipvt,rcond,z) ! in :_disort:src/disort/src/LINPAK.f 842 | real dimension(lda,*) :: abd 843 | integer, optional,check(shape(abd,0)==lda),depend(abd) :: lda=shape(abd,0) 844 | integer :: n 845 | integer :: ml 846 | integer :: mu 847 | integer dimension(*) :: ipvt 848 | real :: rcond 849 | real dimension(*) :: z 850 | end subroutine sgbco 851 | subroutine sgbfa(abd,lda,n,ml,mu,ipvt,info) ! in :_disort:src/disort/src/LINPAK.f 852 | real dimension(lda,*) :: abd 853 | integer, optional,check(shape(abd,0)==lda),depend(abd) :: lda=shape(abd,0) 854 | integer :: n 855 | integer :: ml 856 | integer :: mu 857 | integer dimension(*) :: ipvt 858 | integer :: info 859 | end subroutine sgbfa 860 | subroutine sgbsl(abd,lda,n,ml,mu,ipvt,b,job) ! in :_disort:src/disort/src/LINPAK.f 861 | real dimension(lda,*) :: abd 862 | integer, optional,check(shape(abd,0)==lda),depend(abd) :: lda=shape(abd,0) 863 | integer :: n 864 | integer :: ml 865 | integer :: mu 866 | integer dimension(*) :: ipvt 867 | real dimension(*) :: b 868 | integer :: job 869 | end subroutine sgbsl 870 | subroutine sgeco(a,lda,n,ipvt,rcond,z) ! in :_disort:src/disort/src/LINPAK.f 871 | real dimension(lda,*) :: a 872 | integer, optional,check(shape(a,0)==lda),depend(a) :: lda=shape(a,0) 873 | integer :: n 874 | integer dimension(*) :: ipvt 875 | real :: rcond 876 | real dimension(*) :: z 877 | end subroutine sgeco 878 | subroutine sgefa(a,lda,n,ipvt,info) ! in :_disort:src/disort/src/LINPAK.f 879 | real dimension(lda,*) :: a 880 | integer, optional,check(shape(a,0)==lda),depend(a) :: lda=shape(a,0) 881 | integer :: n 882 | integer dimension(*) :: ipvt 883 | integer :: info 884 | end subroutine sgefa 885 | subroutine sgesl(a,lda,n,ipvt,b,job) ! in :_disort:src/disort/src/LINPAK.f 886 | real dimension(lda,*) :: a 887 | integer, optional,check(shape(a,0)==lda),depend(a) :: lda=shape(a,0) 888 | integer :: n 889 | integer dimension(*) :: ipvt 890 | real dimension(*) :: b 891 | integer :: job 892 | end subroutine sgesl 893 | function sasum(n,sx,incx) ! in :_disort:src/disort/src/LINPAK.f 894 | integer :: n 895 | real dimension(*) :: sx 896 | integer :: incx 897 | real :: sasum 898 | end function sasum 899 | subroutine saxpy(n,sa,sx,incx,sy,incy) ! in :_disort:src/disort/src/LINPAK.f 900 | integer :: n 901 | real :: sa 902 | real dimension(*) :: sx 903 | integer :: incx 904 | real dimension(*) :: sy 905 | integer :: incy 906 | end subroutine saxpy 907 | function sdot(n,sx,incx,sy,incy) ! in :_disort:src/disort/src/LINPAK.f 908 | integer :: n 909 | real dimension(*) :: sx 910 | integer :: incx 911 | real dimension(*) :: sy 912 | integer :: incy 913 | real :: sdot 914 | end function sdot 915 | subroutine sscal(n,sa,sx,incx) ! in :_disort:src/disort/src/LINPAK.f 916 | integer :: n 917 | real :: sa 918 | real dimension(*) :: sx 919 | integer :: incx 920 | end subroutine sscal 921 | subroutine sswap(n,sx,incx,sy,incy) ! in :_disort:src/disort/src/LINPAK.f 922 | integer :: n 923 | real dimension(*) :: sx 924 | integer :: incx 925 | real dimension(*) :: sy 926 | integer :: incy 927 | end subroutine sswap 928 | function isamax(n,sx,incx) ! in :_disort:src/disort/src/LINPAK.f 929 | integer :: n 930 | real dimension(*) :: sx 931 | integer :: incx 932 | integer :: isamax 933 | end function isamax 934 | subroutine prtfin(utau,ntau,umu,numu,phi,nphi,maxulv,maxumu,onlyfl,rfldir,rfldn,flup,dfdt,uu,tstfir,tstfdn,tstfup,tstdfd,tstuu,maxtau,maxmu,maxaz) ! in :_disort:src/disort/src/PRTFIN.f 935 | real dimension(*) :: utau 936 | integer :: ntau 937 | real dimension(*) :: umu 938 | integer :: numu 939 | real dimension(*) :: phi 940 | integer :: nphi 941 | integer, optional,check(shape(uu,1)==maxulv),depend(uu) :: maxulv=shape(uu,1) 942 | integer, optional,check(shape(uu,0)==maxumu),depend(uu) :: maxumu=shape(uu,0) 943 | logical :: onlyfl 944 | real dimension(*) :: rfldir 945 | real dimension(*) :: rfldn 946 | real dimension(*) :: flup 947 | real dimension(*) :: dfdt 948 | real dimension(maxumu,maxulv,*) :: uu 949 | real dimension(*) :: tstfir 950 | real dimension(*) :: tstfdn 951 | real dimension(*) :: tstfup 952 | real dimension(*) :: tstdfd 953 | real dimension(maxtau,maxmu,maxaz) :: tstuu 954 | integer, optional,check(shape(tstuu,0)==maxtau),depend(tstuu) :: maxtau=shape(tstuu,0) 955 | integer, optional,check(shape(tstuu,1)==maxmu),depend(tstuu) :: maxmu=shape(tstuu,1) 956 | integer, optional,check(shape(tstuu,2)==maxaz),depend(tstuu) :: maxaz=shape(tstuu,2) 957 | end subroutine prtfin 958 | function r1mach(i) ! in :_disort:src/disort/src/RDI1MACH.f 959 | integer :: i 960 | real :: r1mach 961 | end function r1mach 962 | function d1mach(i) ! in :_disort:src/disort/src/RDI1MACH.f 963 | integer :: i 964 | double precision :: d1mach 965 | end function d1mach 966 | function i1mach(i) ! in :_disort:src/disort/src/RDI1MACH.f 967 | integer :: i 968 | integer :: i1mach 969 | end function i1mach 970 | subroutine run(maxcly,dtauc,ssalb,maxmom,temper,iphas,gg,wvnmlo,wvnmhi,usrtau,maxulv,utau,nstr,usrang,maxumu,umu,maxphi,phi,ibcnd,fbeam,umu0,phi0,fisot,lamber,albedo,btemp,ttemp,temis,plank,onlyfl,accur,prnt,rfldir,rfldn,flup,dfdt,uavg,uu,albmed,trnmed) ! in :_disort:src/disort/Driver.f 971 | integer, optional,intent(hide),check(len(dtauc)>=maxcly),depend(dtauc) :: maxcly=len(dtauc) 972 | real dimension(maxcly),intent(in) :: dtauc 973 | real dimension(maxcly),intent(in),depend(maxcly) :: ssalb 974 | integer intent(in) :: maxmom 975 | real dimension(maxcly + 1),intent(in),depend(maxcly) :: temper 976 | integer dimension(maxcly),intent(in),depend(maxcly) :: iphas 977 | real dimension(maxcly),intent(in),depend(maxcly) :: gg 978 | real intent(in) :: wvnmlo 979 | real intent(in) :: wvnmhi 980 | logical intent(in) :: usrtau 981 | integer, optional,intent(hide),check(len(utau)>=maxulv),depend(utau) :: maxulv=len(utau) 982 | real dimension(maxulv),intent(in) :: utau 983 | integer intent(in) :: nstr 984 | logical intent(in) :: usrang 985 | integer, optional,intent(hide),check(len(umu)>=maxumu),depend(umu) :: maxumu=len(umu) 986 | real dimension(maxumu),intent(in) :: umu 987 | integer, optional,intent(hide),check(len(phi)>=maxphi),depend(phi) :: maxphi=len(phi) 988 | real dimension(maxphi),intent(in) :: phi 989 | integer intent(in) :: ibcnd 990 | real intent(in) :: fbeam 991 | real intent(in) :: umu0 992 | real intent(in) :: phi0 993 | real intent(in) :: fisot 994 | logical intent(in) :: lamber 995 | real intent(in) :: albedo 996 | real intent(in) :: btemp 997 | real intent(in) :: ttemp 998 | real intent(in) :: temis 999 | logical intent(in) :: plank 1000 | logical intent(in) :: onlyfl 1001 | real intent(in) :: accur 1002 | logical dimension(5),intent(in) :: prnt 1003 | real dimension(maxulv),intent(out),depend(maxulv) :: rfldir 1004 | real dimension(maxulv),intent(out),depend(maxulv) :: rfldn 1005 | real dimension(maxulv),intent(out),depend(maxulv) :: flup 1006 | real dimension(maxulv),intent(out),depend(maxulv) :: dfdt 1007 | real dimension(maxulv),intent(out),depend(maxulv) :: uavg 1008 | real dimension(maxumu,maxulv,maxphi),intent(out),depend(maxumu,maxulv,maxphi) :: uu 1009 | real dimension(maxumu),intent(out),depend(maxumu) :: albmed 1010 | real dimension(maxumu),intent(out),depend(maxumu) :: trnmed 1011 | end subroutine run 1012 | end interface 1013 | end python module _disort 1014 | 1015 | ! This file was auto-generated with f2py (version:2). 1016 | ! See http://cens.ioc.ee/projects/f2py2e/ 1017 | -------------------------------------------------------------------------------- /doc/Makefile: -------------------------------------------------------------------------------- 1 | # Makefile for Sphinx documentation 2 | # 3 | 4 | # You can set these variables from the command line. 5 | SPHINXOPTS = 6 | SPHINXBUILD = sphinx-build 7 | PAPER = 8 | BUILDDIR = build 9 | 10 | # User-friendly check for sphinx-build 11 | ifeq ($(shell which $(SPHINXBUILD) >/dev/null 2>&1; echo $$?), 1) 12 | $(error The '$(SPHINXBUILD)' command was not found. Make sure you have Sphinx installed, then set the SPHINXBUILD environment variable to point to the full path of the '$(SPHINXBUILD)' executable. Alternatively you can add the directory with the executable to your PATH. If you don't have Sphinx installed, grab it from http://sphinx-doc.org/) 13 | endif 14 | 15 | # Internal variables. 16 | PAPEROPT_a4 = -D latex_paper_size=a4 17 | PAPEROPT_letter = -D latex_paper_size=letter 18 | ALLSPHINXOPTS = -d $(BUILDDIR)/doctrees $(PAPEROPT_$(PAPER)) $(SPHINXOPTS) source 19 | # the i18n builder cannot share the environment and doctrees with the others 20 | I18NSPHINXOPTS = $(PAPEROPT_$(PAPER)) $(SPHINXOPTS) source 21 | 22 | .PHONY: help clean html dirhtml singlehtml pickle json htmlhelp qthelp devhelp epub latex latexpdf text man changes linkcheck doctest gettext 23 | 24 | help: 25 | @echo "Please use \`make ' where is one of" 26 | @echo " html to make standalone HTML files" 27 | @echo " dirhtml to make HTML files named index.html in directories" 28 | @echo " singlehtml to make a single large HTML file" 29 | @echo " pickle to make pickle files" 30 | @echo " json to make JSON files" 31 | @echo " htmlhelp to make HTML files and a HTML help project" 32 | @echo " qthelp to make HTML files and a qthelp project" 33 | @echo " devhelp to make HTML files and a Devhelp project" 34 | @echo " epub to make an epub" 35 | @echo " latex to make LaTeX files, you can set PAPER=a4 or PAPER=letter" 36 | @echo " latexpdf to make LaTeX files and run them through pdflatex" 37 | @echo " latexpdfja to make LaTeX files and run them through platex/dvipdfmx" 38 | @echo " text to make text files" 39 | @echo " man to make manual pages" 40 | @echo " texinfo to make Texinfo files" 41 | @echo " info to make Texinfo files and run them through makeinfo" 42 | @echo " gettext to make PO message catalogs" 43 | @echo " changes to make an overview of all changed/added/deprecated items" 44 | @echo " xml to make Docutils-native XML files" 45 | @echo " pseudoxml to make pseudoxml-XML files for display purposes" 46 | @echo " linkcheck to check all external links for integrity" 47 | @echo " doctest to run all doctests embedded in the documentation (if enabled)" 48 | 49 | clean: 50 | rm -rf $(BUILDDIR)/* 51 | 52 | html: 53 | $(SPHINXBUILD) -b html $(ALLSPHINXOPTS) $(BUILDDIR)/html 54 | @echo 55 | @echo "Build finished. The HTML pages are in $(BUILDDIR)/html." 56 | 57 | dirhtml: 58 | $(SPHINXBUILD) -b dirhtml $(ALLSPHINXOPTS) $(BUILDDIR)/dirhtml 59 | @echo 60 | @echo "Build finished. The HTML pages are in $(BUILDDIR)/dirhtml." 61 | 62 | singlehtml: 63 | $(SPHINXBUILD) -b singlehtml $(ALLSPHINXOPTS) $(BUILDDIR)/singlehtml 64 | @echo 65 | @echo "Build finished. The HTML page is in $(BUILDDIR)/singlehtml." 66 | 67 | pickle: 68 | $(SPHINXBUILD) -b pickle $(ALLSPHINXOPTS) $(BUILDDIR)/pickle 69 | @echo 70 | @echo "Build finished; now you can process the pickle files." 71 | 72 | json: 73 | $(SPHINXBUILD) -b json $(ALLSPHINXOPTS) $(BUILDDIR)/json 74 | @echo 75 | @echo "Build finished; now you can process the JSON files." 76 | 77 | htmlhelp: 78 | $(SPHINXBUILD) -b htmlhelp $(ALLSPHINXOPTS) $(BUILDDIR)/htmlhelp 79 | @echo 80 | @echo "Build finished; now you can run HTML Help Workshop with the" \ 81 | ".hhp project file in $(BUILDDIR)/htmlhelp." 82 | 83 | qthelp: 84 | $(SPHINXBUILD) -b qthelp $(ALLSPHINXOPTS) $(BUILDDIR)/qthelp 85 | @echo 86 | @echo "Build finished; now you can run "qcollectiongenerator" with the" \ 87 | ".qhcp project file in $(BUILDDIR)/qthelp, like this:" 88 | @echo "# qcollectiongenerator $(BUILDDIR)/qthelp/pyDISORT.qhcp" 89 | @echo "To view the help file:" 90 | @echo "# assistant -collectionFile $(BUILDDIR)/qthelp/pyDISORT.qhc" 91 | 92 | devhelp: 93 | $(SPHINXBUILD) -b devhelp $(ALLSPHINXOPTS) $(BUILDDIR)/devhelp 94 | @echo 95 | @echo "Build finished." 96 | @echo "To view the help file:" 97 | @echo "# mkdir -p $$HOME/.local/share/devhelp/pyDISORT" 98 | @echo "# ln -s $(BUILDDIR)/devhelp $$HOME/.local/share/devhelp/pyDISORT" 99 | @echo "# devhelp" 100 | 101 | epub: 102 | $(SPHINXBUILD) -b epub $(ALLSPHINXOPTS) $(BUILDDIR)/epub 103 | @echo 104 | @echo "Build finished. The epub file is in $(BUILDDIR)/epub." 105 | 106 | latex: 107 | $(SPHINXBUILD) -b latex $(ALLSPHINXOPTS) $(BUILDDIR)/latex 108 | @echo 109 | @echo "Build finished; the LaTeX files are in $(BUILDDIR)/latex." 110 | @echo "Run \`make' in that directory to run these through (pdf)latex" \ 111 | "(use \`make latexpdf' here to do that automatically)." 112 | 113 | latexpdf: 114 | $(SPHINXBUILD) -b latex $(ALLSPHINXOPTS) $(BUILDDIR)/latex 115 | @echo "Running LaTeX files through pdflatex..." 116 | $(MAKE) -C $(BUILDDIR)/latex all-pdf 117 | @echo "pdflatex finished; the PDF files are in $(BUILDDIR)/latex." 118 | 119 | latexpdfja: 120 | $(SPHINXBUILD) -b latex $(ALLSPHINXOPTS) $(BUILDDIR)/latex 121 | @echo "Running LaTeX files through platex and dvipdfmx..." 122 | $(MAKE) -C $(BUILDDIR)/latex all-pdf-ja 123 | @echo "pdflatex finished; the PDF files are in $(BUILDDIR)/latex." 124 | 125 | text: 126 | $(SPHINXBUILD) -b text $(ALLSPHINXOPTS) $(BUILDDIR)/text 127 | @echo 128 | @echo "Build finished. The text files are in $(BUILDDIR)/text." 129 | 130 | man: 131 | $(SPHINXBUILD) -b man $(ALLSPHINXOPTS) $(BUILDDIR)/man 132 | @echo 133 | @echo "Build finished. The manual pages are in $(BUILDDIR)/man." 134 | 135 | texinfo: 136 | $(SPHINXBUILD) -b texinfo $(ALLSPHINXOPTS) $(BUILDDIR)/texinfo 137 | @echo 138 | @echo "Build finished. The Texinfo files are in $(BUILDDIR)/texinfo." 139 | @echo "Run \`make' in that directory to run these through makeinfo" \ 140 | "(use \`make info' here to do that automatically)." 141 | 142 | info: 143 | $(SPHINXBUILD) -b texinfo $(ALLSPHINXOPTS) $(BUILDDIR)/texinfo 144 | @echo "Running Texinfo files through makeinfo..." 145 | make -C $(BUILDDIR)/texinfo info 146 | @echo "makeinfo finished; the Info files are in $(BUILDDIR)/texinfo." 147 | 148 | gettext: 149 | $(SPHINXBUILD) -b gettext $(I18NSPHINXOPTS) $(BUILDDIR)/locale 150 | @echo 151 | @echo "Build finished. The message catalogs are in $(BUILDDIR)/locale." 152 | 153 | changes: 154 | $(SPHINXBUILD) -b changes $(ALLSPHINXOPTS) $(BUILDDIR)/changes 155 | @echo 156 | @echo "The overview file is in $(BUILDDIR)/changes." 157 | 158 | linkcheck: 159 | $(SPHINXBUILD) -b linkcheck $(ALLSPHINXOPTS) $(BUILDDIR)/linkcheck 160 | @echo 161 | @echo "Link check complete; look for any errors in the above output " \ 162 | "or in $(BUILDDIR)/linkcheck/output.txt." 163 | 164 | doctest: 165 | $(SPHINXBUILD) -b doctest $(ALLSPHINXOPTS) $(BUILDDIR)/doctest 166 | @echo "Testing of doctests in the sources finished, look at the " \ 167 | "results in $(BUILDDIR)/doctest/output.txt." 168 | 169 | xml: 170 | $(SPHINXBUILD) -b xml $(ALLSPHINXOPTS) $(BUILDDIR)/xml 171 | @echo 172 | @echo "Build finished. The XML files are in $(BUILDDIR)/xml." 173 | 174 | pseudoxml: 175 | $(SPHINXBUILD) -b pseudoxml $(ALLSPHINXOPTS) $(BUILDDIR)/pseudoxml 176 | @echo 177 | @echo "Build finished. The pseudo-XML files are in $(BUILDDIR)/pseudoxml." 178 | -------------------------------------------------------------------------------- /doc/README: -------------------------------------------------------------------------------- 1 | make html 2 | -------------------------------------------------------------------------------- /doc/make.bat: -------------------------------------------------------------------------------- 1 | @ECHO OFF 2 | 3 | REM Command file for Sphinx documentation 4 | 5 | if "%SPHINXBUILD%" == "" ( 6 | set SPHINXBUILD=sphinx-build 7 | ) 8 | set BUILDDIR=build 9 | set ALLSPHINXOPTS=-d %BUILDDIR%/doctrees %SPHINXOPTS% source 10 | set I18NSPHINXOPTS=%SPHINXOPTS% source 11 | if NOT "%PAPER%" == "" ( 12 | set ALLSPHINXOPTS=-D latex_paper_size=%PAPER% %ALLSPHINXOPTS% 13 | set I18NSPHINXOPTS=-D latex_paper_size=%PAPER% %I18NSPHINXOPTS% 14 | ) 15 | 16 | if "%1" == "" goto help 17 | 18 | if "%1" == "help" ( 19 | :help 20 | echo.Please use `make ^` where ^ is one of 21 | echo. html to make standalone HTML files 22 | echo. dirhtml to make HTML files named index.html in directories 23 | echo. singlehtml to make a single large HTML file 24 | echo. pickle to make pickle files 25 | echo. json to make JSON files 26 | echo. htmlhelp to make HTML files and a HTML help project 27 | echo. qthelp to make HTML files and a qthelp project 28 | echo. devhelp to make HTML files and a Devhelp project 29 | echo. epub to make an epub 30 | echo. latex to make LaTeX files, you can set PAPER=a4 or PAPER=letter 31 | echo. text to make text files 32 | echo. man to make manual pages 33 | echo. texinfo to make Texinfo files 34 | echo. gettext to make PO message catalogs 35 | echo. changes to make an overview over all changed/added/deprecated items 36 | echo. xml to make Docutils-native XML files 37 | echo. pseudoxml to make pseudoxml-XML files for display purposes 38 | echo. linkcheck to check all external links for integrity 39 | echo. doctest to run all doctests embedded in the documentation if enabled 40 | goto end 41 | ) 42 | 43 | if "%1" == "clean" ( 44 | for /d %%i in (%BUILDDIR%\*) do rmdir /q /s %%i 45 | del /q /s %BUILDDIR%\* 46 | goto end 47 | ) 48 | 49 | 50 | %SPHINXBUILD% 2> nul 51 | if errorlevel 9009 ( 52 | echo. 53 | echo.The 'sphinx-build' command was not found. Make sure you have Sphinx 54 | echo.installed, then set the SPHINXBUILD environment variable to point 55 | echo.to the full path of the 'sphinx-build' executable. Alternatively you 56 | echo.may add the Sphinx directory to PATH. 57 | echo. 58 | echo.If you don't have Sphinx installed, grab it from 59 | echo.http://sphinx-doc.org/ 60 | exit /b 1 61 | ) 62 | 63 | if "%1" == "html" ( 64 | %SPHINXBUILD% -b html %ALLSPHINXOPTS% %BUILDDIR%/html 65 | if errorlevel 1 exit /b 1 66 | echo. 67 | echo.Build finished. The HTML pages are in %BUILDDIR%/html. 68 | goto end 69 | ) 70 | 71 | if "%1" == "dirhtml" ( 72 | %SPHINXBUILD% -b dirhtml %ALLSPHINXOPTS% %BUILDDIR%/dirhtml 73 | if errorlevel 1 exit /b 1 74 | echo. 75 | echo.Build finished. The HTML pages are in %BUILDDIR%/dirhtml. 76 | goto end 77 | ) 78 | 79 | if "%1" == "singlehtml" ( 80 | %SPHINXBUILD% -b singlehtml %ALLSPHINXOPTS% %BUILDDIR%/singlehtml 81 | if errorlevel 1 exit /b 1 82 | echo. 83 | echo.Build finished. The HTML pages are in %BUILDDIR%/singlehtml. 84 | goto end 85 | ) 86 | 87 | if "%1" == "pickle" ( 88 | %SPHINXBUILD% -b pickle %ALLSPHINXOPTS% %BUILDDIR%/pickle 89 | if errorlevel 1 exit /b 1 90 | echo. 91 | echo.Build finished; now you can process the pickle files. 92 | goto end 93 | ) 94 | 95 | if "%1" == "json" ( 96 | %SPHINXBUILD% -b json %ALLSPHINXOPTS% %BUILDDIR%/json 97 | if errorlevel 1 exit /b 1 98 | echo. 99 | echo.Build finished; now you can process the JSON files. 100 | goto end 101 | ) 102 | 103 | if "%1" == "htmlhelp" ( 104 | %SPHINXBUILD% -b htmlhelp %ALLSPHINXOPTS% %BUILDDIR%/htmlhelp 105 | if errorlevel 1 exit /b 1 106 | echo. 107 | echo.Build finished; now you can run HTML Help Workshop with the ^ 108 | .hhp project file in %BUILDDIR%/htmlhelp. 109 | goto end 110 | ) 111 | 112 | if "%1" == "qthelp" ( 113 | %SPHINXBUILD% -b qthelp %ALLSPHINXOPTS% %BUILDDIR%/qthelp 114 | if errorlevel 1 exit /b 1 115 | echo. 116 | echo.Build finished; now you can run "qcollectiongenerator" with the ^ 117 | .qhcp project file in %BUILDDIR%/qthelp, like this: 118 | echo.^> qcollectiongenerator %BUILDDIR%\qthelp\pyDISORT.qhcp 119 | echo.To view the help file: 120 | echo.^> assistant -collectionFile %BUILDDIR%\qthelp\pyDISORT.ghc 121 | goto end 122 | ) 123 | 124 | if "%1" == "devhelp" ( 125 | %SPHINXBUILD% -b devhelp %ALLSPHINXOPTS% %BUILDDIR%/devhelp 126 | if errorlevel 1 exit /b 1 127 | echo. 128 | echo.Build finished. 129 | goto end 130 | ) 131 | 132 | if "%1" == "epub" ( 133 | %SPHINXBUILD% -b epub %ALLSPHINXOPTS% %BUILDDIR%/epub 134 | if errorlevel 1 exit /b 1 135 | echo. 136 | echo.Build finished. The epub file is in %BUILDDIR%/epub. 137 | goto end 138 | ) 139 | 140 | if "%1" == "latex" ( 141 | %SPHINXBUILD% -b latex %ALLSPHINXOPTS% %BUILDDIR%/latex 142 | if errorlevel 1 exit /b 1 143 | echo. 144 | echo.Build finished; the LaTeX files are in %BUILDDIR%/latex. 145 | goto end 146 | ) 147 | 148 | if "%1" == "latexpdf" ( 149 | %SPHINXBUILD% -b latex %ALLSPHINXOPTS% %BUILDDIR%/latex 150 | cd %BUILDDIR%/latex 151 | make all-pdf 152 | cd %BUILDDIR%/.. 153 | echo. 154 | echo.Build finished; the PDF files are in %BUILDDIR%/latex. 155 | goto end 156 | ) 157 | 158 | if "%1" == "latexpdfja" ( 159 | %SPHINXBUILD% -b latex %ALLSPHINXOPTS% %BUILDDIR%/latex 160 | cd %BUILDDIR%/latex 161 | make all-pdf-ja 162 | cd %BUILDDIR%/.. 163 | echo. 164 | echo.Build finished; the PDF files are in %BUILDDIR%/latex. 165 | goto end 166 | ) 167 | 168 | if "%1" == "text" ( 169 | %SPHINXBUILD% -b text %ALLSPHINXOPTS% %BUILDDIR%/text 170 | if errorlevel 1 exit /b 1 171 | echo. 172 | echo.Build finished. The text files are in %BUILDDIR%/text. 173 | goto end 174 | ) 175 | 176 | if "%1" == "man" ( 177 | %SPHINXBUILD% -b man %ALLSPHINXOPTS% %BUILDDIR%/man 178 | if errorlevel 1 exit /b 1 179 | echo. 180 | echo.Build finished. The manual pages are in %BUILDDIR%/man. 181 | goto end 182 | ) 183 | 184 | if "%1" == "texinfo" ( 185 | %SPHINXBUILD% -b texinfo %ALLSPHINXOPTS% %BUILDDIR%/texinfo 186 | if errorlevel 1 exit /b 1 187 | echo. 188 | echo.Build finished. The Texinfo files are in %BUILDDIR%/texinfo. 189 | goto end 190 | ) 191 | 192 | if "%1" == "gettext" ( 193 | %SPHINXBUILD% -b gettext %I18NSPHINXOPTS% %BUILDDIR%/locale 194 | if errorlevel 1 exit /b 1 195 | echo. 196 | echo.Build finished. The message catalogs are in %BUILDDIR%/locale. 197 | goto end 198 | ) 199 | 200 | if "%1" == "changes" ( 201 | %SPHINXBUILD% -b changes %ALLSPHINXOPTS% %BUILDDIR%/changes 202 | if errorlevel 1 exit /b 1 203 | echo. 204 | echo.The overview file is in %BUILDDIR%/changes. 205 | goto end 206 | ) 207 | 208 | if "%1" == "linkcheck" ( 209 | %SPHINXBUILD% -b linkcheck %ALLSPHINXOPTS% %BUILDDIR%/linkcheck 210 | if errorlevel 1 exit /b 1 211 | echo. 212 | echo.Link check complete; look for any errors in the above output ^ 213 | or in %BUILDDIR%/linkcheck/output.txt. 214 | goto end 215 | ) 216 | 217 | if "%1" == "doctest" ( 218 | %SPHINXBUILD% -b doctest %ALLSPHINXOPTS% %BUILDDIR%/doctest 219 | if errorlevel 1 exit /b 1 220 | echo. 221 | echo.Testing of doctests in the sources finished, look at the ^ 222 | results in %BUILDDIR%/doctest/output.txt. 223 | goto end 224 | ) 225 | 226 | if "%1" == "xml" ( 227 | %SPHINXBUILD% -b xml %ALLSPHINXOPTS% %BUILDDIR%/xml 228 | if errorlevel 1 exit /b 1 229 | echo. 230 | echo.Build finished. The XML files are in %BUILDDIR%/xml. 231 | goto end 232 | ) 233 | 234 | if "%1" == "pseudoxml" ( 235 | %SPHINXBUILD% -b pseudoxml %ALLSPHINXOPTS% %BUILDDIR%/pseudoxml 236 | if errorlevel 1 exit /b 1 237 | echo. 238 | echo.Build finished. The pseudo-XML files are in %BUILDDIR%/pseudoxml. 239 | goto end 240 | ) 241 | 242 | :end 243 | -------------------------------------------------------------------------------- /doc/source/conf.py: -------------------------------------------------------------------------------- 1 | # -*- coding: utf-8 -*- 2 | # 3 | # pyDISORT documentation build configuration file, created by 4 | # sphinx-quickstart on Sun Oct 1 19:12:34 2017. 5 | # 6 | # This file is execfile()d with the current directory set to its 7 | # containing dir. 8 | # 9 | # Note that not all possible configuration values are present in this 10 | # autogenerated file. 11 | # 12 | # All configuration values have a default; values that are commented out 13 | # serve to show the default. 14 | 15 | import sys 16 | import os 17 | 18 | # If extensions (or modules to document with autodoc) are in another directory, 19 | # add these directories to sys.path here. If the directory is relative to the 20 | # documentation root, use os.path.abspath to make it absolute, like shown here. 21 | #sys.path.insert(0, os.path.abspath('.')) 22 | 23 | # -- General configuration ------------------------------------------------ 24 | 25 | # If your documentation needs a minimal Sphinx version, state it here. 26 | #needs_sphinx = '1.0' 27 | 28 | # Add any Sphinx extension module names here, as strings. They can be 29 | # extensions coming with Sphinx (named 'sphinx.ext.*') or your custom 30 | # ones. 31 | extensions = [ 32 | 'sphinx.ext.autodoc', 33 | 'sphinx.ext.intersphinx', 34 | 'sphinx.ext.todo', 35 | 'sphinx.ext.ifconfig', 36 | 'sphinx.ext.viewcode', 37 | 'sphinx.ext.autosummary', 38 | # 'numpydoc', 39 | ] 40 | 41 | # Add any paths that contain templates here, relative to this directory. 42 | templates_path = ['_templates'] 43 | 44 | # The suffix of source filenames. 45 | source_suffix = '.rst' 46 | 47 | # The encoding of source files. 48 | #source_encoding = 'utf-8-sig' 49 | 50 | # The master toctree document. 51 | master_doc = 'index' 52 | 53 | # General information about the project. 54 | project = u'pyDISORT' 55 | copyright = u'2017, SGG' 56 | 57 | # The version info for the project you're documenting, acts as replacement for 58 | # |version| and |release|, also used in various other places throughout the 59 | # built documents. 60 | # 61 | # The short X.Y version. 62 | version = '0.0.1' 63 | # The full version, including alpha/beta/rc tags. 64 | release = '0.0.1' 65 | 66 | # The language for content autogenerated by Sphinx. Refer to documentation 67 | # for a list of supported languages. 68 | #language = None 69 | 70 | # There are two options for replacing |today|: either, you set today to some 71 | # non-false value, then it is used: 72 | #today = '' 73 | # Else, today_fmt is used as the format for a strftime call. 74 | #today_fmt = '%B %d, %Y' 75 | 76 | # List of patterns, relative to source directory, that match files and 77 | # directories to ignore when looking for source files. 78 | exclude_patterns = [] 79 | 80 | # The reST default role (used for this markup: `text`) to use for all 81 | # documents. 82 | #default_role = None 83 | 84 | # If true, '()' will be appended to :func: etc. cross-reference text. 85 | #add_function_parentheses = True 86 | 87 | # If true, the current module name will be prepended to all description 88 | # unit titles (such as .. function::). 89 | #add_module_names = True 90 | 91 | # If true, sectionauthor and moduleauthor directives will be shown in the 92 | # output. They are ignored by default. 93 | #show_authors = False 94 | 95 | # The name of the Pygments (syntax highlighting) style to use. 96 | pygments_style = 'sphinx' 97 | 98 | # A list of ignored prefixes for module index sorting. 99 | #modindex_common_prefix = [] 100 | 101 | # If true, keep warnings as "system message" paragraphs in the built documents. 102 | #keep_warnings = False 103 | 104 | 105 | # -- Options for HTML output ---------------------------------------------- 106 | 107 | # The theme to use for HTML and HTML Help pages. See the documentation for 108 | # a list of builtin themes. 109 | html_theme = 'default' 110 | # html_theme = 'haiku' 111 | # html_theme = 'sphinxdoc' 112 | # html_theme = 'scrolls' 113 | # html_theme = 'traditional' 114 | # html_theme = 'pyramid' 115 | # html_theme = 'nature' 116 | # html_theme = 'epub' 117 | # html_theme = 'basic' 118 | # html_theme = 'agogo' 119 | 120 | # Theme options are theme-specific and customize the look and feel of a theme 121 | # further. For a list of options available for each theme, see the 122 | # documentation. 123 | #html_theme_options = {} 124 | 125 | # Add any paths that contain custom themes here, relative to this directory. 126 | #html_theme_path = [] 127 | 128 | # The name for this set of Sphinx documents. If None, it defaults to 129 | # " v documentation". 130 | #html_title = None 131 | 132 | # A shorter title for the navigation bar. Default is the same as html_title. 133 | #html_short_title = None 134 | 135 | # The name of an image file (relative to this directory) to place at the top 136 | # of the sidebar. 137 | #html_logo = None 138 | 139 | # The name of an image file (within the static path) to use as favicon of the 140 | # docs. This file should be a Windows icon file (.ico) being 16x16 or 32x32 141 | # pixels large. 142 | #html_favicon = None 143 | 144 | # Add any paths that contain custom static files (such as style sheets) here, 145 | # relative to this directory. They are copied after the builtin static files, 146 | # so a file named "default.css" will overwrite the builtin "default.css". 147 | html_static_path = ['_static'] 148 | 149 | # Add any extra paths that contain custom files (such as robots.txt or 150 | # .htaccess) here, relative to this directory. These files are copied 151 | # directly to the root of the documentation. 152 | #html_extra_path = [] 153 | 154 | # If not '', a 'Last updated on:' timestamp is inserted at every page bottom, 155 | # using the given strftime format. 156 | #html_last_updated_fmt = '%b %d, %Y' 157 | 158 | # If true, SmartyPants will be used to convert quotes and dashes to 159 | # typographically correct entities. 160 | #html_use_smartypants = True 161 | 162 | # Custom sidebar templates, maps document names to template names. 163 | #html_sidebars = {} 164 | 165 | # Additional templates that should be rendered to pages, maps page names to 166 | # template names. 167 | #html_additional_pages = {} 168 | 169 | # If false, no module index is generated. 170 | #html_domain_indices = True 171 | 172 | # If false, no index is generated. 173 | #html_use_index = True 174 | 175 | # If true, the index is split into individual pages for each letter. 176 | #html_split_index = False 177 | 178 | # If true, links to the reST sources are added to the pages. 179 | #html_show_sourcelink = True 180 | 181 | # If true, "Created using Sphinx" is shown in the HTML footer. Default is True. 182 | #html_show_sphinx = True 183 | 184 | # If true, "(C) Copyright ..." is shown in the HTML footer. Default is True. 185 | #html_show_copyright = True 186 | 187 | # If true, an OpenSearch description file will be output, and all pages will 188 | # contain a tag referring to it. The value of this option must be the 189 | # base URL from which the finished HTML is served. 190 | #html_use_opensearch = '' 191 | 192 | # This is the file name suffix for HTML files (e.g. ".xhtml"). 193 | #html_file_suffix = None 194 | 195 | # Output file base name for HTML help builder. 196 | htmlhelp_basename = 'pyDISORTdoc' 197 | 198 | 199 | # -- Options for LaTeX output --------------------------------------------- 200 | 201 | latex_elements = { 202 | # The paper size ('letterpaper' or 'a4paper'). 203 | #'papersize': 'letterpaper', 204 | 205 | # The font size ('10pt', '11pt' or '12pt'). 206 | #'pointsize': '10pt', 207 | 208 | # Additional stuff for the LaTeX preamble. 209 | #'preamble': '', 210 | } 211 | 212 | # Grouping the document tree into LaTeX files. List of tuples 213 | # (source start file, target name, title, 214 | # author, documentclass [howto, manual, or own class]). 215 | latex_documents = [ 216 | ('index', 'pyDISORT.tex', u'pyDISORT Documentation', 217 | u'SGG', 'manual'), 218 | ] 219 | 220 | # The name of an image file (relative to this directory) to place at the top of 221 | # the title page. 222 | #latex_logo = None 223 | 224 | # For "manual" documents, if this is true, then toplevel headings are parts, 225 | # not chapters. 226 | #latex_use_parts = False 227 | 228 | # If true, show page references after internal links. 229 | #latex_show_pagerefs = False 230 | 231 | # If true, show URL addresses after external links. 232 | #latex_show_urls = False 233 | 234 | # Documents to append as an appendix to all manuals. 235 | #latex_appendices = [] 236 | 237 | # If false, no module index is generated. 238 | #latex_domain_indices = True 239 | 240 | 241 | # -- Options for manual page output --------------------------------------- 242 | 243 | # One entry per manual page. List of tuples 244 | # (source start file, name, description, authors, manual section). 245 | man_pages = [ 246 | ('index', 'pydisort', u'pyDISORT Documentation', 247 | [u'SGG'], 1) 248 | ] 249 | 250 | # If true, show URL addresses after external links. 251 | #man_show_urls = False 252 | 253 | 254 | # -- Options for Texinfo output ------------------------------------------- 255 | 256 | # Grouping the document tree into Texinfo files. List of tuples 257 | # (source start file, target name, title, author, 258 | # dir menu entry, description, category) 259 | texinfo_documents = [ 260 | ('index', 'pyDISORT', u'pyDISORT Documentation', 261 | u'SGG', 'pyDISORT', 'One line description of project.', 262 | 'Miscellaneous'), 263 | ] 264 | 265 | # Documents to append as an appendix to all manuals. 266 | #texinfo_appendices = [] 267 | 268 | # If false, no module index is generated. 269 | #texinfo_domain_indices = True 270 | 271 | # How to display URL addresses: 'footnote', 'no', or 'inline'. 272 | #texinfo_show_urls = 'footnote' 273 | 274 | # If true, do not generate a @detailmenu in the "Top" node's menu. 275 | #texinfo_no_detailmenu = False 276 | -------------------------------------------------------------------------------- /doc/source/disort.rst: -------------------------------------------------------------------------------- 1 | .. _coda_base-module: 2 | 3 | Disort Module 4 | ================= 5 | 6 | This module contains a python wrapper function `run` to call the fortran function `disort` 7 | 8 | .. automodule:: disort 9 | :members: 10 | 11 | -------------------------------------------------------------------------------- /doc/source/index.rst: -------------------------------------------------------------------------------- 1 | .. pyDISORT documentation master file, created by 2 | sphinx-quickstart on Sun Oct 1 19:12:34 2017. 3 | You can adapt this file completely to your liking, but it should at least 4 | contain the root `toctree` directive. 5 | 6 | Welcome to pyDISORT's documentation! 7 | ==================================== 8 | 9 | Contents: 10 | 11 | .. toctree:: 12 | :maxdepth: 2 13 | 14 | disort 15 | 16 | Indices and tables 17 | ================== 18 | 19 | * :ref:`genindex` 20 | * :ref:`modindex` 21 | * :ref:`search` 22 | 23 | -------------------------------------------------------------------------------- /lib/disort/__init__.py: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env python 2 | """ 3 | Python wrapper to the DISORT library 4 | 5 | Module '_disort' is auto-generated with f2py (version:2). 6 | """ 7 | from __version__ import __version__ 8 | 9 | import _disort 10 | 11 | ########################################################################################################## 12 | # 13 | # functions 14 | # 15 | ########################################################################################################## 16 | 17 | def run(dTau, w0=1., iphas=2, gg=0.85, 18 | umu0=1., phi0=0., albedo=0.1, fbeam=1.0, 19 | UsrTau=True, utau=0., UsrAng=True, umu=1., 20 | phi=0., Nstr=32, maxmom=299, lamber=True, 21 | onlyFl=False, accur=0., plank=False, 22 | temp=300., wvnmlo=999., wvnmhi=1000., 23 | ibcnd=0, fisot=0., btemp=300., ttemp=300., 24 | temis=1., prnt=[False]*5, verbose=1): 25 | 26 | """ 27 | 28 | performs radiative transfer simulations by means of the DISORT RT solver 29 | 30 | Parameters 31 | ---------- 32 | dTau : array 33 | optical thickness in atmospheric layers 34 | w0 : float, array 35 | single scattering albedo (Default: 1.) 36 | iphas : int, array 37 | scattering phase function type (Default 2). 38 | 1 : Isotropic 39 | 2 : Rayleigh 40 | 3 : Henyey-Greenstein with asymmetry factor GG 41 | 4 : Haze L as specified by Garcia/Siewert 42 | 5 : Cloud C.1 as specified by Garcia/Siewert 43 | gg : float, array 44 | scattering asymmetry parameter (Default: 0.85) 45 | umu0 : float 46 | cosine of solar zenith angle (Default: 1.) 47 | phi0 : float 48 | solar azimuth angle (Default: 0.) 49 | albedo : float 50 | surface albedo (Default: 0.1) 51 | fbeam : float 52 | solar irradiance (Default: 1.) 53 | utau : float, array 54 | optical thickness where to output the RT fields (Default: 0.) 55 | umu : float, array 56 | cosine of viewing zenith angle where to output the RT fields (Default: 1.) 57 | phi : float, array 58 | viewing azimuth angle where to output the RT fields (Default: 0.) 59 | maxmom : int 60 | Max. number of Legendre coefficients. (Default: 299) 61 | Nstr : int 62 | Number of computational polar angles to be used 63 | (= number of 'streams') ( should be even and .GE. 2 ). 64 | (Default: 32) 65 | temp : float, array 66 | LEV = 0 to NLYR, Temperatures (K) of levels. 67 | (Note that temperature is specified at LEVELS 68 | rather than for layers.) Be sure to put top level 69 | temperature in TEMPER(0), not TEMPER(1). Top and 70 | bottom level values do not need to agree with top and 71 | bottom boundary temperatures (i.e. temperature 72 | discontinuities are allowed). (Default: 300.) 73 | wvnmlo, wvnmhi : float 74 | Wavenumbers (inv cm) of spectral interval of interest 75 | ( used only for calculating Planck function ). 76 | Needed only if PLANK is TRUE, or in multiple runs, if 77 | LAMBER is FALSE and BDREF depends on spectral interval. 78 | (Default: wvnmlo=999., wvnmhi=1000.) 79 | UsrTau : logical 80 | = FALSE, Radiant quantities are to be returned 81 | at boundary of every computational layer. 82 | = TRUE, Radiant quantities are to be returned 83 | at user-specified optical depths 84 | (Default: True) 85 | UsrAng : logical 86 | = FALSE, Radiant quantities are to be returned 87 | at computational polar angles. 88 | = TRUE, Radiant quantities are to be returned 89 | at user-specified polar angles. 90 | (Default: True) 91 | ibcnd : int 92 | = 0, General case: boundary conditions any combination of: 93 | * beam illumination from the top ( see FBEAM ) 94 | * isotropic illumination from the top ( see FISOT ) 95 | * thermal emission from the top ( see TEMIS, TTEMP ) 96 | * internal thermal emission sources ( see TEMPER ) 97 | * reflection at the bottom ( see LAMBER, ALBEDO, BDREF ) 98 | * thermal emission from the bottom ( see BTEMP ) 99 | = 1, Return only albedo and transmissivity of the entire 100 | medium vs. incident beam angle; see S2 for details. 101 | (Default: 0) 102 | fisot : float 103 | Intensity of top-boundary isotropic illumination. 104 | [same units as PLKAVG (default W/sq m) if thermal 105 | sources active, otherwise arbitrary units]. 106 | Corresponding incident flux is pi (3.14159...) 107 | times FISOT. 108 | (Default: 0.) 109 | lamber : bool 110 | = TRUE, isotropically reflecting bottom boundary. 111 | = FALSE, bidirectionally reflecting bottom boundary. 112 | (Default: True) 113 | btemp : float 114 | Temperature of bottom boundary (K) (bottom emissivity 115 | is calculated from ALBEDO or function BDREF, so it need 116 | not be specified). Needed only if PLANK is TRUE. 117 | (Default: 300.) 118 | ttemp : float 119 | Temperature of top boundary (K). 120 | Needed only if PLANK is TRUE. 121 | (Default: 300.) 122 | temis : float 123 | Emissivity of top boundary. 124 | Needed only if PLANK is TRUE. 125 | (Default: 1.) 126 | plank : bool 127 | = TRUE, include thermal emission 128 | = FALSE, ignore all thermal emission (saves computer time) 129 | (Default: False) 130 | onlyFl : bool 131 | = TRUE, return fluxes, flux divergences, and mean 132 | intensities. 133 | = FALSE, return fluxes, flux divergences, mean 134 | intensities, AND intensities. 135 | (Default: False) 136 | accur : float 137 | Convergence criterion for azimuthal (Fourier cosine) 138 | series. Will stop when the following occurs twice: 139 | largest term being added is less than ACCUR times 140 | total series sum. (Twice because there are cases where 141 | terms are anomalously small but azimuthal series has 142 | not converged.) Should be between 0 and 0.01 to avoid 143 | risk of serious non-convergence. Has no effect on 144 | problems lacking a beam source, since azimuthal series 145 | has only one term in that case. 146 | (Default: 0.) 147 | PRNT : array(dtype=bool) 148 | Array of LOGICAL print flags causing the following prints 149 | === =============================================== 150 | L quantities printed 151 | === =============================================== 152 | 1 input variables (except PMOM) 153 | 2 fluxes 154 | 3 intensities at user levels and angles 155 | 4 planar transmissivity and planar albedo 156 | as a function solar zenith angle ( IBCND = 1 ) 157 | 5 phase function moments PMOM for each layer 158 | ( only if PRNT(1) = TRUE, and only for layers 159 | with scattering ) 160 | === =============================================== 161 | (Default: array([False False False False False])) 162 | 163 | Returns 164 | ------- 165 | ds_fields : list of arrays 166 | [rfldir, rfldn, flup, dfdt, uavg, uu, albmed, trnmed] 167 | 168 | rfldir : Downward Direct 169 | rfldn : Downward Diffuse 170 | flup : Upward Diffuse 171 | dfdt : d(Net Flux) / d(Op Dep) 172 | uu : Intensity 173 | uavg : Mean intensity (including the direct beam) 174 | (Not corrected for delta-M-scaling effects) 175 | albmed : Albedo of the medium as a function of incident 176 | beam angle cosine UMU(IU) (IBCND = 1 case only) 177 | trnmed : Transmissivity of the medium as a function of incident 178 | beam angle cosine UMU(IU) (IBCND = 1 case only) 179 | 180 | Examples 181 | -------- 182 | >>> import disort 183 | >>> D_dir, D_diff, U_up, dFdt, I = disort.run(dTau, ssalb, iphas='Rayleigh') 184 | """ 185 | 186 | import numpy as np 187 | 188 | if not hasattr(w0,'__iter__'): 189 | w0 = w0 * np.ones_like(dTau) 190 | if not hasattr(iphas,'__iter__'): 191 | iphas = iphas * np.ones_like(dTau) 192 | if not hasattr(gg,'__iter__'): 193 | gg = gg * np.ones_like(dTau) 194 | if not hasattr(temp,'__iter__'): 195 | temp = temp * np.ones(len(dTau)+1) 196 | if not hasattr(utau,'__iter__'): 197 | utau = np.array([utau]) 198 | if not hasattr(umu,'__iter__'): 199 | umu = np.array([umu]) 200 | if not hasattr(phi,'__iter__'): 201 | phi = np.array([phi]) 202 | if not hasattr(prnt,'__iter__'): 203 | prnt = prnt * np.ones(5, dtype='bool') 204 | 205 | if verbose > 0: 206 | print ' **************************************************************'+\ 207 | '**************************************' 208 | print ' DISORT: Python wrapper to the DISORT radiative transfer solver' 209 | print ' **************************************************************'+\ 210 | '**************************************' 211 | 212 | rfldir, rfldn, flup, dfdt, uavg, uu, albmed, trnmed = \ 213 | _disort.run(dTau, w0, maxmom, temp, iphas, gg, 214 | wvnmlo, wvnmhi, UsrTau, utau, Nstr, 215 | UsrAng, umu, phi, ibcnd, fbeam, 216 | umu0, phi0, fisot, lamber, albedo, btemp, 217 | ttemp, temis, plank, onlyFl, accur, prnt) 218 | 219 | return rfldir, rfldn, flup, dfdt, uavg, uu, albmed, trnmed 220 | -------------------------------------------------------------------------------- /lib/disort/__version__.py: -------------------------------------------------------------------------------- 1 | __version__ = '0.0.1' 2 | -------------------------------------------------------------------------------- /setup.py: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env python 2 | # ------------------------------------------------------ 3 | # Adapted from setup.py from CliMT project 4 | # ------------------------------------------------------ 5 | 6 | import os 7 | import sys 8 | import glob 9 | import string 10 | from numpy.distutils.core import setup 11 | from numpy.distutils import fcompiler 12 | from distutils.dep_util import newer 13 | 14 | from numpy import f2py 15 | f2py_path = f2py.__path__[0] 16 | direct = f2py_path 17 | while 1: 18 | base = os.path.basename(direct) 19 | if base=='': 20 | print '*f2py* not found in your python installation' 21 | raise SystemExit(0) 22 | direct = os.path.dirname(direct) 23 | if base=='lib' or base=='lib64': 24 | root = direct 25 | if 'bin' in os.listdir(root): 26 | f2py_exec_path = os.path.join(root,'bin') 27 | if 'f2py' in os.listdir(f2py_exec_path): 28 | f2py_bin = os.path.join(f2py_exec_path,'f2py') 29 | break 30 | 31 | Extensions = [ 32 | {'name':'disort', 33 | 'dir':'src/disort'}, 34 | ] 35 | 36 | # figure out which compiler we're goint to use 37 | compiler = fcompiler.get_default_fcompiler(requiref90=True) 38 | compiler = 'gnu95' # ensure gfortran 39 | for i in range(len(sys.argv)): 40 | if '--fcompiler' in sys.argv[i]: 41 | compiler = sys.argv.pop(i) 42 | compiler = compiler[compiler.index('=')+1:] 43 | print 'Using %s compiler' % compiler 44 | 45 | # set some fortran compiler-dependent flags 46 | if compiler == 'gnu95' or compiler == 'gnu': 47 | # f77flags='-ffixed-line-length-132 -fdefault-real-8' 48 | # f90flags='-fdefault-real-8' 49 | f77flags='-O3' 50 | f90flags='-O3' 51 | elif compiler == 'intel' or compiler == 'intelem': 52 | f77flags='-132 -r8 -w95 -w90 -mp' 53 | f90flags='-r8 -w95 -mp' 54 | elif compiler == 'ibm': 55 | f77flags='-qautodbl=dbl4 -qsuffix=f=f:cpp=F -qfixed=132' 56 | f90flags='-qautodbl=dbl4 -qsuffix=f=f90:cpp=F90 -qfree=f90' 57 | else: 58 | print 'Sorry, compiler %s not supported' % compiler 59 | sys.exit() 60 | 61 | for i in range(len(Extensions)): 62 | Defaults = { # 'cppflags':'-DIM=%i -DJM=%i -DKM=%i' % (IM,JM,KM), 63 | 'cppflags':'', 64 | 'f77flags':f77flags, 65 | 'f90flags':f90flags} 66 | Defaults.update(Extensions[i]) 67 | Extensions[i] = Defaults 68 | 69 | if compiler == 'ibm': 70 | for ext in Extensions: 71 | ext['cppflags']='-WF,'+string.join(ext['cppflags'].split(),',') 72 | 73 | def getSources(dir): 74 | # Gets list of source files for extensions 75 | SrcFile = os.path.join(dir,'sources_in_order_of_compilation') 76 | if os.path.exists(SrcFile): 77 | Sources = open(SrcFile).readlines() 78 | Sources = [os.path.join(dir,s[:-1]) for s in Sources] 79 | else: 80 | Sources = [] 81 | for pattern in ['*.f','*.F','*.f90','*.F90']: 82 | Sources += glob.glob(os.path.join(dir,'src',pattern)) # sgg: i changed to order 83 | Sources += glob.glob(os.path.join(dir,pattern)) # 84 | return Sources 85 | 86 | def buildNeeded(target,src): 87 | # Checks if source code is newer than extension, so extension needs to be rebuilt 88 | target = os.path.join('lib/disort',target) 89 | if not os.path.exists(target): 90 | return True 91 | for file in src: 92 | if newer(file,target): 93 | return True 94 | print 'Extension %s is up to date' % os.path.basename(target) 95 | return False 96 | 97 | def build_ext(name=None, dir=None, cppflags='', f77flags='', f90flags='', 98 | lib='', libdir='', incdir=''): 99 | # Builds an extension 100 | src = getSources(dir) 101 | target = '_%s.so' % name 102 | driver = glob.glob(os.path.join(dir,'Driver.f'))[0] 103 | f77flags = '"%s %s"' % (cppflags,f77flags) 104 | f90flags = '"%s %s"' % (cppflags,f90flags) 105 | if buildNeeded(target,src): 106 | print '\n Building %s ... \n' % os.path.basename(target) 107 | # generate signature file 108 | #os.system('f2py --overwrite-signature %s -m _%s -h _%s.pyf'%(driver,name,name)) 109 | ff = '%s '*len(src) 110 | #sformat = '/usr/bin/f2py --overwrite-signature '+ff+' -m _%s -h _%s.pyf' 111 | sformat = f2py_bin+' --overwrite-signature '+ff+' -m _%s -h _%s.pyf' 112 | args = src + [name,name] 113 | print sformat % tuple(args) 114 | os.system(sformat % tuple(args)) 115 | # compile extension 116 | F2pyCommand = [] 117 | # F2pyCommand.append('/usr/bin/f2py -c -m _%s' % name) 118 | F2pyCommand.append('%s -c ' % f2py_bin) 119 | F2pyCommand.append('--fcompiler=%s' % compiler) 120 | F2pyCommand.append('-I%s' % dir) 121 | F2pyCommand.append('-I%s' % os.path.join(dir,'include')) 122 | F2pyCommand.append('-I%s' % os.path.join(dir,'src')) 123 | F2pyCommand.append('-I%s' % os.path.join(dir,'src','include')) 124 | if incdir is not '': 125 | for i in incdir: 126 | F2pyCommand.append('-I%s' % i) 127 | if libdir is not '': 128 | for i in libdir: 129 | F2pyCommand.append('-L%s' % i) 130 | if lib is not '': 131 | for i in lib: 132 | F2pyCommand.append('-l%s' % i) 133 | F2pyCommand.append('--f77flags=%s' % f77flags) 134 | F2pyCommand.append('--f90flags=%s' % f90flags) 135 | F2pyCommand.append('_%s.pyf' % name) 136 | F2pyCommand.append('%s' % string.join(src)) 137 | F2pyCommand = string.join(F2pyCommand) 138 | print F2pyCommand 139 | if os.system(F2pyCommand) > 0: 140 | print '+++ Compilation failed' 141 | sys.exit() 142 | os.system('mv -f _%s.so lib/disort' % name) 143 | # os.system('rm -f _%s.pyf' % name) 144 | 145 | # Build all extensions 146 | for ext in Extensions: 147 | build_ext(**ext) 148 | 149 | # Finish the setup 150 | # note: setup() cannot copy directories, and falls over 151 | # trying to copy the CVS directory in climt/lib/data 152 | # workaround: make data list which specifically excludes CVS 153 | os.chdir('lib/') 154 | DataFiles = [] 155 | for File in glob.glob('test/*.py'): 156 | if 'CVS' not in File: 157 | DataFiles.append('../'+File) 158 | print DataFiles 159 | os.chdir('..') 160 | 161 | setup(name = "disort", 162 | version = open('Version').read()[:-1], 163 | description = "Python wrapper to the DISORT library", 164 | author = "Sebati\'an Gimeno Garc\'\ia", 165 | author_email = "sebastian.gimenogarcia@gmail.com", 166 | packages = ['disort'], 167 | package_dir = {'':'lib'}, 168 | package_data = {'disort':['*.so']+DataFiles}) 169 | -------------------------------------------------------------------------------- /src/disort/Driver.f: -------------------------------------------------------------------------------- 1 | c ------------------------------------------------------------------- 2 | c Python wrapper to the DISORT radiative transfer solver 3 | c 4 | c Author: Sebastian Gimeno Garcia 5 | c 6 | c 7 | c License: 8 | c 9 | c Do whatever you want with this piece of code. Enjoy it. If you 10 | c find it helpful, think about the authors of DISORT and drink to 11 | c their health, and why not, also to mine. 12 | c 13 | c If you find any bug, please let me now. 14 | c 15 | c Ref: 16 | c 17 | c K. Stamnes, SC. Tsay, W. Wiscombe and K. Jayaweera, Numerically 18 | c stable algorithm for discrete-ordinate-method radiative 19 | c transfer in multiple scattering and emitting layered media, 20 | c Appl Opt 27 (1988) (12), pp. 2502–2509. 21 | c ------------------------------------------------------------------- 22 | 23 | c ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 24 | c Driver based on: 25 | c 26 | c RCS version control information: 27 | c $Header: DISOTEST.f,v 2.1 2000/04/03 21:21:55 laszlo Exp $ 28 | c ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 29 | 30 | SUBROUTINE RUN( 31 | I MAXCLY, DTAUC, SSALB, MAXMOM, TEMPER, 32 | I IPHAS, GG, 33 | I WVNMLO, WVNMHI, USRTAU, MAXULV, UTAU, NSTR, 34 | I USRANG, MAXUMU, UMU, MAXPHI, PHI, IBCND, FBEAM, 35 | I UMU0, PHI0, FISOT, LAMBER, ALBEDO, BTEMP, 36 | I TTEMP, TEMIS, PLANK, ONLYFL, ACCUR, PRNT, 37 | O RFLDIR, RFLDN, FLUP, DFDT, UAVG, UU, 38 | O ALBMED, TRNMED 39 | & ) 40 | 41 | 42 | c Runs test problems for DISORT and checks answers. These 43 | c problems test almost all logical branches in DISORT. 44 | 45 | c It is HIGHLY recommended that you use the code below as a template 46 | c for creating your own CALLs to DISORT, rather than starting from 47 | c scratch. This will prevent a lot of mistakes and ensure that every 48 | c input argument gets a value. Note in particular how GETMOM is 49 | c sometimes called to fill an array section of PMOM (for one layer); 50 | c several people have done this incorrectly in attempting to write it 51 | c ab initio (passing array sections for arrays that do not start at 52 | c element 1 is tricky). 53 | 54 | c Note that the ratio to the 'correct answer' may occasionally be 55 | c significantly different from unity -- even so different that 56 | c the ratio just prints as ****** rather than a number. However, 57 | c this mostly occurs for values of flux or intensity that are very 58 | c small compared to the forcing functions (that is, small compared 59 | c to internal thermal emission and/or radiation incident at the 60 | c boundaries). The printed number 'SERIOUSLY NON-UNIT RATIOS' 61 | c attempts to count just the cases where there is a real disagreement 62 | c and not those where quantitites are down at their noise level 63 | c (defined as 10^(-6) times their maximum value). 64 | 65 | c Further documentation can be found in the file DISOTEST.doc. 66 | 67 | 68 | c Routines called : 69 | 70 | c DISORT: The discrete ordinates radiative transfer program 71 | 72 | c BDREF: Sets bidirectional reflectance of lower boundary 73 | 74 | c GETMOM: Sets phase function Legendre coefficients 75 | 76 | c PRTFIN: Prints fluxes and intensities and their ratios to 77 | c the correct values 78 | 79 | c CHEKDO: Data block containing correct fluxes and intensities 80 | 81 | c RATIO : Ratio of calculated to correct value with underflow 82 | c and overflow protection (kept in file DISORT.f) 83 | 84 | c INPUT: IPHAS Phase function options 85 | c 1 : Isotropic 86 | c 2 : Rayleigh 87 | c 3 : Henyey-Greenstein with asymmetry factor GG 88 | c 4 : Haze L as specified by Garcia/Siewert 89 | c 5 : Cloud C.1 as specified by Garcia/Siewert 90 | 91 | c GG Asymmetry factor for Henyey-Greenstein case 92 | 93 | c NMOM Index of highest Legendre coefficient needed 94 | c ( = number of streams 'NSTR' chosen 95 | c for the discrete ordinate method) 96 | c+---------------------------------------------------------------------+ 97 | c 98 | c ** DISORT I/O specifications ** 99 | 100 | CF2PY INTENT(HIDE) :: MAXCLY, MAXUMU, MAXPHI, MAXULV 101 | CF2PY INTENT(IN) :: DTAUC, SSALB, TEMPER, MAXMOM 102 | CF2PY INTENT(IN) :: IPHAS, GG, 103 | CF2PY INTENT(IN) :: WVNMLO, WVNMHI, USRTAU, UTAU, NSTR 104 | CF2PY INTENT(IN) :: USRANG, UMU, PHI, IBCND, FBEAM 105 | CF2PY INTENT(IN) :: UMU0, PHI0, FISOT, LAMBER, ALBEDO, BTEMP 106 | CF2PY INTENT(IN) :: TTEMP, TEMIS, PLANK, ONLYFL, ACCUR, PRNT 107 | CF2PY INTENT(OUT) :: RFLDIR, RFLDN, FLUP, DFDT, UAVG, UU 108 | CF2PY INTENT(OUT) :: ALBMED, TRNMED 109 | 110 | INTEGER MAXCLY, MAXULV, MAXUMU, MAXPHI 111 | INTEGER MAXMOM 112 | c$$ PARAMETER ( MAXMOM = 299) 113 | CHARACTER HEADER*127 114 | LOGICAL LAMBER, PLANK, ONLYFL, PRNT(5), USRANG, USRTAU 115 | INTEGER IBCND, NMOM, NLYR, NUMU, NSTR, NPHI, NTAU 116 | REAL ACCUR, ALBEDO, BTEMP, DTAUC( MAXCLY ), FBEAM, FISOT, 117 | & PHI( MAXPHI ), PMOM( 0:MAXMOM, MAXCLY ), 118 | & PHI0, SSALB( MAXCLY ), TEMPER( 0:MAXCLY ), TEMIS, TTEMP, 119 | & WVNMLO, WVNMHI, UMU( MAXUMU ), UMU0, UTAU( MAXULV ) 120 | 121 | REAL RFLDIR( MAXULV ), RFLDN( MAXULV ), FLUP( MAXULV ), 122 | & DFDT( MAXULV ), UAVG( MAXULV ), 123 | & UU( MAXUMU, MAXULV, MAXPHI ), ALBMED( MAXUMU ), 124 | & TRNMED( MAXUMU ) 125 | 126 | INTEGER IPHAS( MAXCLY ) 127 | REAL GG( MAXCLY ) 128 | 129 | c+---------------------------------------------------------------------+ 130 | 131 | INTEGER MXTAU, MXMU, MXPHI 132 | PARAMETER ( MXTAU = 5, MXMU = 32, MXPHI = 3 ) 133 | INTEGER LC 134 | REAL PI 135 | 136 | c+---------------------------------------------------------------------+ 137 | c .. External Subroutines .. 138 | 139 | EXTERNAL DISORT, ERRMSG, GETMOM, PRTFIN 140 | c .. 141 | c .. Intrinsic Functions .. 142 | 143 | INTRINSIC ASIN, FLOAT, INDEX 144 | c .. 145 | 146 | 147 | PI = 2.* ASIN( 1.0 ) 148 | 149 | NLYR = MAXCLY 150 | NMOM = NSTR 151 | DO LC = 1, NLYR 152 | CALL GETMOM( IPHAS( LC ), GG( LC ), NMOM, PMOM(0,LC) ) 153 | END DO 154 | NTAU = MAXULV 155 | NPHI = MAXPHI 156 | NUMU = MAXUMU 157 | HEADER = 'Python wrapper to the DISORT radiative transfer solver' 158 | 159 | CALL DISORT( NLYR, DTAUC, SSALB, NMOM, PMOM, TEMPER, 160 | & WVNMLO, WVNMHI, USRTAU, NTAU, UTAU, NSTR, 161 | & USRANG, NUMU, UMU, NPHI, PHI, IBCND, FBEAM, 162 | & UMU0, PHI0, FISOT, LAMBER, ALBEDO, BTEMP, 163 | & TTEMP, TEMIS, PLANK, ONLYFL, ACCUR, PRNT, 164 | & HEADER, MAXCLY, MAXULV, MAXUMU, MAXPHI, 165 | & MAXMOM, RFLDIR, RFLDN, FLUP, DFDT, UAVG, UU, 166 | & ALBMED, TRNMED ) 167 | 168 | 169 | END 170 | -------------------------------------------------------------------------------- /src/disort/src/BDREF.f: -------------------------------------------------------------------------------- 1 | c ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 2 | c RCS version control information: 3 | c $Header: BDREF.f,v 2.1 2000/03/27 21:40:51 laszlo Exp $ 4 | c ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 5 | 6 | REAL FUNCTION BDREF( WVNMLO, WVNMHI, MU, MUP, DPHI ) 7 | 8 | c Supplies surface bi-directional reflectivity. 9 | c 10 | c This is only a "stub" version. The user must replace this 11 | c by his/her own BDREF function. 12 | c 13 | c 14 | c NOTE 1: Bidirectional reflectivity in DISORT is defined 15 | c by Eq. 39 in STWL. 16 | c NOTE 2: Both MU and MU0 (cosines of reflection and incidence 17 | c angles) are positive. 18 | c 19 | c INPUT: 20 | c 21 | c WVNMLO : Lower wavenumber (inv cm) of spectral interval 22 | c 23 | c WVNMHI : Upper wavenumber (inv cm) of spectral interval 24 | c 25 | c MU : Cosine of angle of reflection (positive) 26 | c 27 | c MUP : Cosine of angle of incidence (positive) 28 | c 29 | c DPHI : Difference of azimuth angles of incidence and reflection 30 | c (radians) 31 | c 32 | c 33 | c Called by- DREF, SURFAC 34 | 35 | c +-------------------------------------------------------------------+ 36 | c 37 | c .. Scalar Arguments .. 38 | 39 | REAL DPHI, MU, MUP, WVNMHI, WVNMLO 40 | c .. 41 | c .. External Subroutines .. 42 | 43 | EXTERNAL ERRMSG 44 | c .. 45 | 46 | WRITE ( *, '(//,7(1X,A,/))' ) 47 | & 'To use a bidirectionally reflecting lower boundary you must', 48 | & 'replace file BDREF.f with your own file. In that file, you ', 49 | & 'should supply the bidirectional reflectivity, as a function ', 50 | & 'of the cosine of angle of reflection, the cosine of angle ', 51 | & 'of incidence, and the difference of azimuth angles of ', 52 | & 'incidence and reflection. See DISORT.doc for more information', 53 | & 'and subroutine BDREF in file DISOTEST.f for an example.' 54 | 55 | CALL ERRMSG( 'BDREF--Please supply a surface BDRF model', .TRUE. ) 56 | 57 | BDREF = 0.0 58 | 59 | RETURN 60 | END 61 | -------------------------------------------------------------------------------- /src/disort/src/ErrPack.f: -------------------------------------------------------------------------------- 1 | c ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 2 | c RCS version control information: 3 | c $Header: ErrPack.f,v 2.1 2000/03/27 21:40:49 laszlo Exp $ 4 | c ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 5 | 6 | SUBROUTINE ErrMsg( MESSAG, FATAL ) 7 | 8 | c Print out a warning or error message; abort if error 9 | 10 | LOGICAL FATAL, MsgLim 11 | CHARACTER*(*) MESSAG 12 | INTEGER MaxMsg, NumMsg 13 | SAVE MaxMsg, NumMsg, MsgLim 14 | DATA NumMsg / 0 /, MaxMsg / 100 /, MsgLim / .FALSE. / 15 | 16 | 17 | IF ( FATAL ) THEN 18 | WRITE ( *, '(/,2A,/)' ) ' ******* ERROR >>>>>> ', MESSAG 19 | STOP 20 | END IF 21 | 22 | NumMsg = NumMsg + 1 23 | IF( MsgLim ) RETURN 24 | 25 | IF ( NumMsg.LE.MaxMsg ) THEN 26 | WRITE ( *, '(/,2A,/)' ) ' ******* WARNING >>>>>> ', MESSAG 27 | ELSE 28 | WRITE ( *,99 ) 29 | MsgLim = .True. 30 | ENDIF 31 | 32 | RETURN 33 | 34 | 99 FORMAT( //,' >>>>>> TOO MANY WARNING MESSAGES -- ', 35 | & 'They will no longer be printed <<<<<<<', // ) 36 | END 37 | 38 | LOGICAL FUNCTION WrtBad ( VarNam ) 39 | 40 | c Write names of erroneous variables and return 'TRUE' 41 | 42 | c INPUT : VarNam = Name of erroneous variable to be written 43 | c ( CHARACTER, any length ) 44 | 45 | CHARACTER*(*) VarNam 46 | INTEGER MaxMsg, NumMsg 47 | SAVE NumMsg, MaxMsg 48 | DATA NumMsg / 0 /, MaxMsg / 50 / 49 | 50 | 51 | WrtBad = .TRUE. 52 | NumMsg = NumMsg + 1 53 | WRITE ( *, '(3A)' ) ' **** Input variable ', VarNam, 54 | & ' in error ****' 55 | IF ( NumMsg.EQ.MaxMsg ) 56 | & CALL ErrMsg ( 'Too many input errors. Aborting...', .TRUE. ) 57 | 58 | RETURN 59 | END 60 | 61 | LOGICAL FUNCTION WrtDim ( DimNam, MinVal ) 62 | 63 | c Write name of too-small symbolic dimension and 64 | c the value it should be increased to; return 'TRUE' 65 | 66 | c INPUT : DimNam = Name of symbolic dimension which is too small 67 | c ( CHARACTER, any length ) 68 | c Minval = Value to which that dimension should be 69 | c increased (at least) 70 | 71 | CHARACTER*(*) DimNam 72 | INTEGER MinVal 73 | 74 | 75 | WRITE ( *, '(/,3A,I7)' ) ' **** Symbolic dimension ', DimNam, 76 | & ' should be increased to at least ', MinVal 77 | WrtDim = .TRUE. 78 | 79 | RETURN 80 | END 81 | 82 | LOGICAL FUNCTION TstBad( VarNam, RelErr ) 83 | 84 | c Write name (VarNam) of variable failing self-test and its 85 | c percent error from the correct value; return 'FALSE'. 86 | 87 | CHARACTER*(*) VarNam 88 | REAL RelErr 89 | 90 | 91 | TstBad = .FALSE. 92 | WRITE( *, '(/,3A,1P,E11.2,A)' ) 93 | & ' Output variable ', VarNam,' differed by ', 100.*RelErr, 94 | & ' per cent from correct value. Self-test failed.' 95 | 96 | RETURN 97 | END 98 | 99 | -------------------------------------------------------------------------------- /src/disort/src/GETMOM.f: -------------------------------------------------------------------------------- 1 | SUBROUTINE GETMOM( IPHAS, GG, NMOM, PMOM ) 2 | 3 | c Calculate phase function Legendre expansion coefficients 4 | c in various special cases 5 | 6 | 7 | c INPUT: IPHAS Phase function options 8 | c 1 : Isotropic 9 | c 2 : Rayleigh 10 | c 3 : Henyey-Greenstein with asymmetry factor GG 11 | c 4 : Haze L as specified by Garcia/Siewert 12 | c 5 : Cloud C.1 as specified by Garcia/Siewert 13 | 14 | c GG Asymmetry factor for Henyey-Greenstein case 15 | 16 | c NMOM Index of highest Legendre coefficient needed 17 | c ( = number of streams 'NSTR' chosen 18 | c for the discrete ordinate method) 19 | 20 | c OUTPUT: PMOM(K) Legendre expansion coefficients (K=0 to NMOM) 21 | c (be sure to dimension '0:maxval' in calling 22 | c program) 23 | 24 | c Reference: Garcia, R. and C. Siewert, 1985: Benchmark Results 25 | c in Radiative Transfer, Transp. Theory and Stat. 26 | c Physics 14, 437-484, Tables 10 And 17 27 | c ------------------------------------------------------------------ 28 | 29 | c .. Scalar Arguments .. 30 | 31 | INTEGER IPHAS, NMOM 32 | REAL GG 33 | c .. 34 | c .. Array Arguments .. 35 | 36 | REAL PMOM( 0:NMOM ) 37 | c .. 38 | c .. Local Scalars .. 39 | 40 | INTEGER K 41 | c .. 42 | c .. Local Arrays .. 43 | 44 | REAL CLDMOM( 299 ), HAZELM( 82 ) 45 | c .. 46 | c .. External Subroutines .. 47 | 48 | EXTERNAL ERRMSG 49 | c .. 50 | c .. Intrinsic Functions .. 51 | 52 | INTRINSIC MIN 53 | c .. 54 | 55 | DATA HAZELM / 2.41260, 3.23047, 3.37296, 3.23150, 2.89350, 56 | A 2.49594, 2.11361, 1.74812, 1.44692, 1.17714, 57 | B 0.96643, 0.78237, 0.64114, 0.51966, 0.42563, 58 | C 0.34688, 0.28351, 0.23317, 0.18963, 0.15788, 59 | D 0.12739, 0.10762, 0.08597, 0.07381, 0.05828, 60 | E 0.05089, 0.03971, 0.03524, 0.02720, 0.02451, 61 | F 0.01874, 0.01711, 0.01298, 0.01198, 0.00904, 62 | G 0.00841, 0.00634, 0.00592, 0.00446, 0.00418, 63 | H 0.00316, 0.00296, 0.00225, 0.00210, 0.00160, 64 | I 0.00150, 0.00115, 0.00107, 0.00082, 0.00077, 65 | J 0.00059, 0.00055, 0.00043, 0.00040, 0.00031, 66 | K 0.00029, 0.00023, 0.00021, 0.00017, 0.00015, 67 | L 0.00012, 0.00011, 0.00009, 0.00008, 0.00006, 68 | M 0.00006, 0.00005, 0.00004, 0.00004, 0.00003, 69 | N 0.00003, 3*0.00002, 8*0.00001 / 70 | 71 | DATA ( CLDMOM(K), K = 1, 159 ) / 72 | A 2.544, 3.883, 4.568, 5.235, 5.887, 6.457, 7.177, 7.859, 73 | B 8.494, 9.286, 9.856, 10.615, 11.229, 11.851, 12.503, 13.058, 74 | C 13.626, 14.209, 14.660, 15.231, 15.641, 16.126, 16.539, 16.934, 75 | D 17.325, 17.673, 17.999, 18.329, 18.588, 18.885, 19.103, 19.345, 76 | E 19.537, 19.721, 19.884, 20.024, 20.145, 20.251, 20.330, 20.401, 77 | F 20.444, 20.477, 20.489, 20.483, 20.467, 20.427, 20.382, 20.310, 78 | G 20.236, 20.136, 20.036, 19.909, 19.785, 19.632, 19.486, 19.311, 79 | H 19.145, 18.949, 18.764, 18.551, 18.348, 18.119, 17.901, 17.659, 80 | I 17.428, 17.174, 16.931, 16.668, 16.415, 16.144, 15.883, 15.606, 81 | J 15.338, 15.058, 14.784, 14.501, 14.225, 13.941, 13.662, 13.378, 82 | K 13.098, 12.816, 12.536, 12.257, 11.978, 11.703, 11.427, 11.156, 83 | L 10.884, 10.618, 10.350, 10.090, 9.827, 9.574, 9.318, 9.072, 84 | M 8.822, 8.584, 8.340, 8.110, 7.874, 7.652, 7.424, 7.211, 6.990, 85 | N 6.785, 6.573, 6.377, 6.173, 5.986, 5.790, 5.612, 5.424, 5.255, 86 | O 5.075, 4.915, 4.744, 4.592, 4.429, 4.285, 4.130, 3.994, 3.847, 87 | P 3.719, 3.580, 3.459, 3.327, 3.214, 3.090, 2.983, 2.866, 2.766, 88 | Q 2.656, 2.562, 2.459, 2.372, 2.274, 2.193, 2.102, 2.025, 1.940, 89 | R 1.869, 1.790, 1.723, 1.649, 1.588, 1.518, 1.461, 1.397, 1.344, 90 | S 1.284, 1.235, 1.179, 1.134, 1.082, 1.040, 0.992, 0.954, 0.909 / 91 | DATA ( CLDMOM(K), K = 160, 299 ) / 92 | T 0.873, 0.832, 0.799, 0.762, 0.731, 0.696, 0.668, 0.636, 0.610, 93 | U 0.581, 0.557, 0.530, 0.508, 0.483, 0.463, 0.440, 0.422, 0.401, 94 | V 0.384, 0.364, 0.349, 0.331, 0.317, 0.301, 0.288, 0.273, 0.262, 95 | W 0.248, 0.238, 0.225, 0.215, 0.204, 0.195, 0.185, 0.177, 0.167, 96 | X 0.160, 0.151, 0.145, 0.137, 0.131, 0.124, 0.118, 0.112, 0.107, 97 | Y 0.101, 0.097, 0.091, 0.087, 0.082, 0.079, 0.074, 0.071, 0.067, 98 | Z 0.064, 0.060, 0.057, 0.054, 0.052, 0.049, 0.047, 0.044, 0.042, 99 | A 0.039, 0.038, 0.035, 0.034, 0.032, 0.030, 0.029, 0.027, 0.026, 100 | B 0.024, 0.023, 0.022, 0.021, 0.020, 0.018, 0.018, 0.017, 0.016, 101 | C 0.015, 0.014, 0.013, 0.013, 0.012, 0.011, 0.011, 0.010, 0.009, 102 | D 0.009, 3*0.008, 2*0.007, 3*0.006, 4*0.005, 4*0.004, 6*0.003, 103 | E 9*0.002, 18*0.001 / 104 | 105 | 106 | IF ( IPHAS.LT.1 .OR. IPHAS.GT.5 ) 107 | & CALL ERRMSG( 'GETMOM--bad input variable IPHAS',.TRUE.) 108 | 109 | IF ( IPHAS.EQ.3 .AND. (GG.LE.-1.0 .OR. GG.GE.1.0) ) 110 | & CALL ERRMSG( 'GETMOM--bad input variable GG',.TRUE.) 111 | 112 | IF ( NMOM.LT.2 ) 113 | & CALL ERRMSG( 'GETMOM--bad input variable NMOM',.TRUE.) 114 | 115 | 116 | PMOM(0) = 1.0 117 | DO 10 K = 1, NMOM 118 | PMOM(K) = 0.0 119 | 10 CONTINUE 120 | 121 | 122 | IF ( IPHAS.EQ.2 ) THEN 123 | c ** Rayleigh phase function 124 | PMOM(2) = 0.1 125 | 126 | ELSE IF ( IPHAS.EQ.3 ) THEN 127 | c ** Henyey-Greenstein phase fcn 128 | DO 20 K = 1, NMOM 129 | PMOM(K) = GG**K 130 | 20 CONTINUE 131 | 132 | ELSE IF ( IPHAS.EQ.4 ) THEN 133 | c ** Haze-L phase function 134 | DO 30 K = 1, MIN(82,NMOM) 135 | PMOM(K) = HAZELM(K) / ( 2*K+1 ) 136 | 30 CONTINUE 137 | 138 | ELSE IF ( IPHAS.EQ.5 ) THEN 139 | c ** Cloud C.1 phase function 140 | DO 40 K = 1, MIN(298,NMOM) 141 | PMOM(K) = CLDMOM(K) / ( 2*K+1 ) 142 | 40 CONTINUE 143 | 144 | END IF 145 | 146 | END 147 | 148 | -------------------------------------------------------------------------------- /src/disort/src/LINPAK.f: -------------------------------------------------------------------------------- 1 | c ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 2 | c RCS version control information: 3 | c $Header: LINPAK.f,v 2.1 2000/03/27 21:40:49 laszlo Exp $ 4 | c ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 5 | 6 | c Call tree: 7 | c 8 | c SGBCO 9 | c SASUM 10 | c SDOT 11 | c SAXPY 12 | c SGBFA 13 | c ISAMAX 14 | c SAXPY 15 | c SSCAL 16 | c SSCAL 17 | c SGBSL 18 | c SDOT 19 | c SAXPY 20 | c SGECO 21 | c SASUM 22 | c SDOT 23 | c SAXPY 24 | c SGEFA 25 | c ISAMAX 26 | c SAXPY 27 | c SSCAL 28 | c SSCAL 29 | c SGESL 30 | c SDOT 31 | c SAXPY 32 | c SSWAP 33 | c ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 34 | 35 | 36 | SUBROUTINE SGBCO( ABD, LDA, N, ML, MU, IPVT, RCOND, Z ) 37 | 38 | c Factors a real band matrix by Gaussian elimination 39 | c and estimates the condition of the matrix. 40 | 41 | c Revision date: 8/1/82 42 | c Author: Moler, C. B. (U. of New Mexico) 43 | 44 | c If RCOND is not needed, SGBFA is slightly faster. 45 | c To solve A*X = B , follow SBGCO by SGBSL. 46 | 47 | c input: 48 | 49 | C ABD REAL(LDA, N) 50 | c contains the matrix in band storage. The columns 51 | c of the matrix are stored in the columns of ABD and 52 | c the diagonals of the matrix are stored in rows 53 | c ML+1 through 2*ML+MU+1 of ABD . 54 | c See the comments below for details. 55 | 56 | C LDA INTEGER 57 | c the leading dimension of the array ABD . 58 | c LDA must be .GE. 2*ML + MU + 1 . 59 | 60 | C N INTEGER 61 | c the order of the original matrix. 62 | 63 | C ML INTEGER 64 | c number of diagonals below the main diagonal. 65 | c 0 .LE. ML .LT. N . 66 | 67 | C MU INTEGER 68 | c number of diagonals above the main diagonal. 69 | c 0 .LE. MU .LT. N . 70 | c more efficient if ML .LE. MU . 71 | 72 | c on return 73 | 74 | c ABD an upper triangular matrix in band storage and 75 | c the multipliers which were used to obtain it. 76 | c The factorization can be written A = L*U where 77 | c L is a product of permutation and unit lower 78 | c triangular matrices and U is upper triangular. 79 | 80 | C IPVT INTEGER(N) 81 | c an integer vector of pivot indices. 82 | 83 | C RCOND REAL 84 | c an estimate of the reciprocal condition of A . 85 | c For the system A*X = B , relative perturbations 86 | c in A and B of size epsilon may cause 87 | c relative perturbations in X of size epsilon/RCOND . 88 | c If RCOND is so small that the logical expression 89 | c 1.0 + RCOND .EQ. 1.0 90 | c is true, then A may be singular to working 91 | c precision. In particular, RCOND is zero if 92 | c exact singularity is detected or the estimate 93 | c underflows. 94 | 95 | C Z REAL(N) 96 | c a work vector whose contents are usually unimportant. 97 | c If A is close to a singular matrix, then Z is 98 | c an approximate null vector in the sense that 99 | c norm(a*z) = rcond*norm(a)*norm(z) . 100 | 101 | c Band storage 102 | 103 | c If A is a band matrix, the following program segment 104 | c will set up the input. 105 | 106 | c ML = (band width below the diagonal) 107 | c MU = (band width above the diagonal) 108 | c M = ML + MU + 1 109 | c DO 20 J = 1, N 110 | c I1 = MAX(1, J-MU) 111 | c I2 = MIN(N, J+ML) 112 | c DO 10 I = I1, I2 113 | c K = I - J + M 114 | c ABD(K,J) = A(I,J) 115 | c 10 CONTINUE 116 | c 20 CONTINUE 117 | 118 | c This uses rows ML+1 through 2*ML+MU+1 of ABD . 119 | c In addition, the first ML rows in ABD are used for 120 | c elements generated during the triangularization. 121 | c The total number of rows needed in ABD is 2*ML+MU+1 . 122 | c The ML+MU by ML+MU upper left triangle and the 123 | c ML by ML lower right triangle are not referenced. 124 | 125 | c Example: if the original matrix is 126 | 127 | c 11 12 13 0 0 0 128 | c 21 22 23 24 0 0 129 | c 0 32 33 34 35 0 130 | c 0 0 43 44 45 46 131 | c 0 0 0 54 55 56 132 | c 0 0 0 0 65 66 133 | 134 | c then N = 6, ML = 1, MU = 2, LDA .GE. 5 and ABD should contain 135 | 136 | c * * * + + + , * = not used 137 | c * * 13 24 35 46 , + = used for pivoting 138 | c * 12 23 34 45 56 139 | c 11 22 33 44 55 66 140 | c 21 32 43 54 65 * 141 | 142 | c -------------------------------------------------------------------- 143 | 144 | 145 | c .. Scalar Arguments .. 146 | 147 | INTEGER LDA, ML, MU, N 148 | REAL RCOND 149 | c .. 150 | c .. Array Arguments .. 151 | 152 | INTEGER IPVT( * ) 153 | REAL ABD( LDA, * ), Z( * ) 154 | c .. 155 | c .. Local Scalars .. 156 | 157 | INTEGER INFO, IS, J, JU, K, KB, KP1, L, LA, LM, LZ, M, MM 158 | REAL ANORM, EK, S, SM, T, WK, WKM, YNORM 159 | c .. 160 | c .. External Functions .. 161 | 162 | REAL SASUM, SDOT 163 | EXTERNAL SASUM, SDOT 164 | c .. 165 | c .. External Subroutines .. 166 | 167 | EXTERNAL SAXPY, SGBFA, SSCAL 168 | c .. 169 | c .. Intrinsic Functions .. 170 | 171 | INTRINSIC ABS, MAX, MIN, SIGN 172 | c .. 173 | 174 | 175 | c ** compute 1-norm of A 176 | ANORM = 0.0E0 177 | L = ML + 1 178 | IS = L + MU 179 | 180 | DO 10 J = 1, N 181 | 182 | ANORM = MAX( ANORM, SASUM( L,ABD( IS,J ),1 ) ) 183 | 184 | IF( IS.GT.ML + 1 ) IS = IS - 1 185 | 186 | IF( J.LE.MU ) L = L + 1 187 | 188 | IF( J.GE.N - ML ) L = L - 1 189 | 190 | 10 CONTINUE 191 | c ** factor 192 | 193 | CALL SGBFA( ABD, LDA, N, ML, MU, IPVT, INFO ) 194 | 195 | c RCOND = 1/(norm(A)*(estimate of norm(inverse(A)))) . 196 | c estimate = norm(Z)/norm(Y) where A*Z = Y and trans(A)*Y = E. 197 | c trans(A) is the transpose of A. The components of E are 198 | c chosen to cause maximum local growth in the elements of W where 199 | c trans(U)*W = E. The vectors are frequently rescaled to avoid 200 | c overflow. 201 | 202 | c ** solve trans(U)*W = E 203 | EK = 1.0E0 204 | 205 | DO 20 J = 1, N 206 | Z( J ) = 0.0E0 207 | 20 CONTINUE 208 | 209 | 210 | M = ML + MU + 1 211 | JU = 0 212 | 213 | DO 50 K = 1, N 214 | 215 | IF( Z( K ).NE.0.0E0 ) EK = SIGN( EK, -Z( K ) ) 216 | 217 | IF( ABS( EK - Z( K ) ).GT.ABS( ABD( M,K ) ) ) THEN 218 | 219 | S = ABS( ABD( M,K ) ) / ABS( EK - Z( K ) ) 220 | 221 | CALL SSCAL( N, S, Z, 1 ) 222 | 223 | EK = S*EK 224 | 225 | END IF 226 | 227 | WK = EK - Z( K ) 228 | WKM = -EK - Z( K ) 229 | S = ABS( WK ) 230 | SM = ABS( WKM ) 231 | 232 | IF( ABD( M,K ).NE.0.0E0 ) THEN 233 | 234 | WK = WK / ABD( M, K ) 235 | WKM = WKM / ABD( M, K ) 236 | 237 | ELSE 238 | 239 | WK = 1.0E0 240 | WKM = 1.0E0 241 | 242 | END IF 243 | 244 | KP1 = K + 1 245 | JU = MIN( MAX( JU,MU + IPVT( K ) ), N ) 246 | MM = M 247 | 248 | IF( KP1.LE.JU ) THEN 249 | 250 | DO 30 J = KP1, JU 251 | MM = MM - 1 252 | SM = SM + ABS( Z( J ) + WKM*ABD( MM,J ) ) 253 | Z( J ) = Z( J ) + WK*ABD( MM, J ) 254 | S = S + ABS( Z( J ) ) 255 | 30 CONTINUE 256 | 257 | IF( S.LT.SM ) THEN 258 | 259 | T = WKM - WK 260 | WK = WKM 261 | MM = M 262 | 263 | DO 40 J = KP1, JU 264 | MM = MM - 1 265 | Z( J ) = Z( J ) + T*ABD( MM, J ) 266 | 40 CONTINUE 267 | 268 | END IF 269 | 270 | END IF 271 | 272 | Z( K ) = WK 273 | 274 | 50 CONTINUE 275 | 276 | 277 | S = 1.0E0 / SASUM( N, Z, 1 ) 278 | 279 | CALL SSCAL( N, S, Z, 1 ) 280 | 281 | c ** solve trans(L)*Y = W 282 | DO 60 KB = 1, N 283 | K = N + 1 - KB 284 | LM = MIN( ML, N - K ) 285 | 286 | IF( K.LT.N ) 287 | & Z( K ) = Z( K ) + SDOT( LM, ABD( M+1, K ), 1, Z( K+1 ), 1 ) 288 | 289 | IF( ABS( Z( K ) ).GT.1.0E0 ) THEN 290 | 291 | S = 1.0E0 / ABS( Z( K ) ) 292 | 293 | CALL SSCAL( N, S, Z, 1 ) 294 | 295 | END IF 296 | 297 | L = IPVT( K ) 298 | T = Z( L ) 299 | Z( L ) = Z( K ) 300 | Z( K ) = T 301 | 302 | 60 CONTINUE 303 | 304 | 305 | S = 1.0E0 / SASUM( N, Z, 1 ) 306 | 307 | CALL SSCAL( N, S, Z, 1 ) 308 | 309 | YNORM = 1.0E0 310 | c ** solve L*V = Y 311 | DO 70 K = 1, N 312 | 313 | L = IPVT( K ) 314 | T = Z( L ) 315 | Z( L ) = Z( K ) 316 | Z( K ) = T 317 | LM = MIN( ML, N - K ) 318 | 319 | IF( K.LT.N ) 320 | & CALL SAXPY( LM, T, ABD( M+1, K ), 1, Z( K+1 ), 1 ) 321 | 322 | IF( ABS( Z(K) ).GT.1.0E0 ) THEN 323 | 324 | S = 1.0E0 / ABS( Z(K) ) 325 | 326 | CALL SSCAL( N, S, Z, 1 ) 327 | 328 | YNORM = S*YNORM 329 | 330 | END IF 331 | 332 | 70 CONTINUE 333 | 334 | 335 | S = 1.0E0 / SASUM( N, Z, 1 ) 336 | 337 | CALL SSCAL( N, S, Z, 1 ) 338 | 339 | YNORM = S*YNORM 340 | 341 | c ** solve U*Z = W 342 | DO 80 KB = 1, N 343 | 344 | K = N + 1 - KB 345 | 346 | IF( ABS( Z( K ) ).GT.ABS( ABD( M,K ) ) ) THEN 347 | 348 | S = ABS( ABD( M,K ) ) / ABS( Z( K ) ) 349 | 350 | CALL SSCAL( N, S, Z, 1 ) 351 | 352 | YNORM = S*YNORM 353 | 354 | END IF 355 | 356 | IF( ABD( M,K ).NE.0.0E0 ) Z( K ) = Z( K ) / ABD( M, K ) 357 | IF( ABD( M,K ).EQ.0.0E0 ) Z( K ) = 1.0E0 358 | 359 | LM = MIN( K, M ) - 1 360 | LA = M - LM 361 | LZ = K - LM 362 | T = -Z( K ) 363 | 364 | CALL SAXPY( LM, T, ABD( LA,K ), 1, Z( LZ ), 1 ) 365 | 366 | 80 CONTINUE 367 | c ** make znorm = 1.0 368 | 369 | S = 1.0E0 / SASUM( N, Z, 1 ) 370 | 371 | CALL SSCAL( N, S, Z, 1 ) 372 | 373 | YNORM = S*YNORM 374 | IF( ANORM.NE.0.0E0 ) RCOND = YNORM / ANORM 375 | IF( ANORM.EQ.0.0E0 ) RCOND = 0.0E0 376 | 377 | END 378 | 379 | SUBROUTINE SGBFA( ABD, LDA, N, ML, MU, IPVT, INFO ) 380 | 381 | c Factors a real band matrix by elimination. 382 | 383 | c Revision date: 8/1/82 384 | c Author: Moler, C. B. (U. of New Mexico) 385 | 386 | c SGBFA is usually called by SBGCO, but it can be called 387 | c directly with a saving in time if RCOND is not needed. 388 | 389 | c Input: same as SGBCO 390 | 391 | c On return: 392 | 393 | c ABD,IPVT same as SGBCO 394 | 395 | c INFO INTEGER 396 | c = 0 normal value. 397 | c = k if u(k,k) .eq. 0.0 . This is not an error 398 | c condition for this subroutine, but it does 399 | c indicate that SGBSL will divide by zero if 400 | c called. Use RCOND in SBGCO for a reliable 401 | c indication of singularity. 402 | 403 | c (see SGBCO for description of band storage mode) 404 | 405 | c ---------------------------------------------------------------- 406 | 407 | 408 | c .. Scalar Arguments .. 409 | 410 | INTEGER INFO, LDA, ML, MU, N 411 | c .. 412 | c .. Array Arguments .. 413 | 414 | INTEGER IPVT( * ) 415 | REAL ABD( LDA, * ) 416 | c .. 417 | c .. Local Scalars .. 418 | 419 | INTEGER I, I0, J, J0, J1, JU, JZ, K, KP1, L, LM, M, MM, NM1 420 | REAL T 421 | c .. 422 | c .. External Functions .. 423 | 424 | INTEGER ISAMAX 425 | EXTERNAL ISAMAX 426 | c .. 427 | c .. External Subroutines .. 428 | 429 | EXTERNAL SAXPY, SSCAL 430 | c .. 431 | c .. Intrinsic Functions .. 432 | 433 | INTRINSIC MAX, MIN 434 | c .. 435 | 436 | 437 | M = ML + MU + 1 438 | INFO = 0 439 | c ** zero initial fill-in columns 440 | J0 = MU + 2 441 | J1 = MIN( N, M ) - 1 442 | 443 | DO 20 JZ = J0, J1 444 | 445 | I0 = M + 1 - JZ 446 | 447 | DO 10 I = I0, ML 448 | ABD( I, JZ ) = 0.0E0 449 | 10 CONTINUE 450 | 451 | 20 CONTINUE 452 | 453 | JZ = J1 454 | JU = 0 455 | c ** Gaussian elimination with partial pivoting 456 | NM1 = N - 1 457 | 458 | DO 50 K = 1, NM1 459 | 460 | KP1 = K + 1 461 | c ** zero next fill-in column 462 | JZ = JZ + 1 463 | 464 | IF( JZ.LE.N ) THEN 465 | 466 | DO 30 I = 1, ML 467 | ABD( I, JZ ) = 0.0E0 468 | 30 CONTINUE 469 | 470 | END IF 471 | c ** find L = pivot index 472 | LM = MIN( ML, N - K ) 473 | L = ISAMAX( LM + 1, ABD( M, K ), 1 ) + M - 1 474 | IPVT( K ) = L + K - M 475 | 476 | IF( ABD( L,K ).EQ.0.0E0 ) THEN 477 | c ** zero pivot implies this column 478 | c ** already triangularized 479 | INFO = K 480 | 481 | ELSE 482 | c ** interchange if necessary 483 | IF( L.NE.M ) THEN 484 | 485 | T = ABD( L, K ) 486 | ABD( L, K ) = ABD( M, K ) 487 | ABD( M, K ) = T 488 | END IF 489 | c ** compute multipliers 490 | T = - 1.0E0 / ABD( M, K ) 491 | 492 | CALL SSCAL( LM, T, ABD( M + 1,K ), 1 ) 493 | 494 | c ** row elimination with column indexing 495 | 496 | JU = MIN( MAX( JU,MU + IPVT( K ) ), N ) 497 | MM = M 498 | 499 | DO 40 J = KP1, JU 500 | 501 | L = L - 1 502 | MM = MM - 1 503 | T = ABD( L, J ) 504 | 505 | IF( L.NE.MM ) THEN 506 | 507 | ABD( L, J ) = ABD( MM, J ) 508 | ABD( MM, J ) = T 509 | 510 | END IF 511 | 512 | CALL SAXPY( LM, T, ABD( M+1, K ), 1, ABD( MM+1, J ), 1) 513 | 514 | 40 CONTINUE 515 | 516 | END IF 517 | 518 | 50 CONTINUE 519 | 520 | 521 | IPVT( N ) = N 522 | IF( ABD( M,N ).EQ.0.0E0 ) INFO = N 523 | 524 | END 525 | 526 | SUBROUTINE SGBSL( ABD, LDA, N, ML, MU, IPVT, B, JOB ) 527 | 528 | c Solves the real band system 529 | c A * X = B or transpose(A) * X = B 530 | c using the factors computed by SBGCO or SGBFA. 531 | 532 | c Revision date: 8/1/82 533 | c Author: Moler, C. B. (U. of New Mexico) 534 | 535 | c Input: 536 | 537 | C ABD REAL(LDA, N) 538 | c the output from SBGCO or SGBFA. 539 | 540 | C LDA INTEGER 541 | c the leading dimension of the array ABD . 542 | 543 | C N INTEGER 544 | c the order of the original matrix. 545 | 546 | C ML INTEGER 547 | c number of diagonals below the main diagonal. 548 | 549 | C MU INTEGER 550 | c number of diagonals above the main diagonal. 551 | 552 | C IPVT INTEGER(N) 553 | c the pivot vector from SBGCO or SGBFA. 554 | 555 | C B REAL(N) 556 | c the right hand side vector. 557 | 558 | C JOB INTEGER 559 | c = 0 to solve A*X = B , 560 | c = nonzero to solve transpose(A)*X = B 561 | 562 | c On return 563 | 564 | c B the solution vector X 565 | 566 | c Error condition 567 | 568 | c A division by zero will occur if the input factor contains a 569 | c zero on the diagonal. Technically, this indicates singularity, 570 | c but it is often caused by improper arguments or improper 571 | c setting of LDA . It will not occur if the subroutines are 572 | c called correctly and if SBGCO has set RCOND .GT. 0.0 573 | c or SGBFA has set INFO .EQ. 0 . 574 | 575 | c To compute inverse(a) * c where c is a matrix 576 | c with p columns 577 | c call sgbco(abd,lda,n,ml,mu,ipvt,rcond,z) 578 | c if (rcond is too small) go to ... 579 | c do 10 j = 1, p 580 | c call sgbsl(abd,lda,n,ml,mu,ipvt,c(1,j),0) 581 | c 10 continue 582 | 583 | c -------------------------------------------------------- 584 | 585 | c .. Scalar Arguments .. 586 | 587 | INTEGER JOB, LDA, ML, MU, N 588 | c .. 589 | c .. Array Arguments .. 590 | 591 | INTEGER IPVT( * ) 592 | REAL ABD( LDA, * ), B( * ) 593 | c .. 594 | c .. Local Scalars .. 595 | 596 | INTEGER K, KB, L, LA, LB, LM, M, NM1 597 | REAL T 598 | c .. 599 | c .. External Functions .. 600 | 601 | REAL SDOT 602 | EXTERNAL SDOT 603 | c .. 604 | c .. External Subroutines .. 605 | 606 | EXTERNAL SAXPY 607 | c .. 608 | c .. Intrinsic Functions .. 609 | 610 | INTRINSIC MIN 611 | c .. 612 | 613 | 614 | M = MU + ML + 1 615 | NM1 = N - 1 616 | 617 | IF( JOB.EQ.0 ) THEN 618 | c ** solve A * X = B 619 | 620 | c ** first solve L*Y = B 621 | IF( ML.NE.0 ) THEN 622 | 623 | DO 10 K = 1, NM1 624 | 625 | LM = MIN( ML, N - K ) 626 | L = IPVT( K ) 627 | T = B( L ) 628 | 629 | IF( L.NE.K ) THEN 630 | 631 | B( L ) = B( K ) 632 | B( K ) = T 633 | 634 | END IF 635 | 636 | CALL SAXPY( LM, T, ABD( M + 1,K ), 1, B( K + 1 ), 1 ) 637 | 638 | 10 CONTINUE 639 | 640 | END IF 641 | 642 | c ** now solve U*X = Y 643 | DO 20 KB = 1, N 644 | 645 | K = N + 1 - KB 646 | B( K ) = B( K ) / ABD( M, K ) 647 | LM = MIN( K, M ) - 1 648 | LA = M - LM 649 | LB = K - LM 650 | T = -B( K ) 651 | 652 | CALL SAXPY( LM, T, ABD( LA,K ), 1, B( LB ), 1 ) 653 | 654 | 20 CONTINUE 655 | 656 | 657 | ELSE 658 | c ** solve trans(A) * X = B 659 | 660 | c ** first solve trans(U)*Y = B 661 | DO 30 K = 1, N 662 | 663 | LM = MIN( K, M ) - 1 664 | LA = M - LM 665 | LB = K - LM 666 | T = SDOT( LM, ABD( LA,K ), 1, B( LB ), 1 ) 667 | B( K ) = ( B( K ) - T ) / ABD( M, K ) 668 | 669 | 30 CONTINUE 670 | 671 | c ** now solve trans(L)*X = Y 672 | IF( ML.NE.0 ) THEN 673 | 674 | DO 40 KB = 1, NM1 675 | 676 | K = N - KB 677 | LM = MIN( ML, N - K ) 678 | B( K ) = B( K ) + SDOT( LM, ABD( M+1, K ), 1, 679 | & B( K+1 ), 1 ) 680 | L = IPVT( K ) 681 | 682 | IF( L.NE.K ) THEN 683 | 684 | T = B( L ) 685 | B( L ) = B( K ) 686 | B( K ) = T 687 | 688 | END IF 689 | 690 | 40 CONTINUE 691 | 692 | END IF 693 | 694 | END IF 695 | 696 | END 697 | 698 | SUBROUTINE SGECO( A, LDA, N, IPVT, RCOND, Z ) 699 | 700 | c Factors a real matrix by Gaussian elimination 701 | c and estimates the condition of the matrix. 702 | 703 | c Revision date: 8/1/82 704 | c Author: Moler, C. B. (U. of New Mexico) 705 | 706 | c If RCOND is not needed, SGEFA is slightly faster. 707 | c To solve A*X = B , follow SGECO by SGESL. 708 | 709 | c On entry 710 | 711 | c A REAL(LDA, N) 712 | c the matrix to be factored. 713 | 714 | c LDA INTEGER 715 | c the leading dimension of the array A . 716 | 717 | c N INTEGER 718 | c the order of the matrix A . 719 | 720 | c On return 721 | 722 | c A an upper triangular matrix and the multipliers 723 | c which were used to obtain it. 724 | c The factorization can be written A = L*U , where 725 | c L is a product of permutation and unit lower 726 | c triangular matrices and U is upper triangular. 727 | 728 | c IPVT INTEGER(N) 729 | c an integer vector of pivot indices. 730 | 731 | c RCOND REAL 732 | c an estimate of the reciprocal condition of A . 733 | c For the system A*X = B , relative perturbations 734 | c in A and B of size epsilon may cause 735 | c relative perturbations in X of size epsilon/RCOND . 736 | c If RCOND is so small that the logical expression 737 | c 1.0 + RCOND .EQ. 1.0 738 | c is true, then A may be singular to working 739 | c precision. In particular, RCOND is zero if 740 | c exact singularity is detected or the estimate 741 | c underflows. 742 | 743 | C Z REAL(N) 744 | c a work vector whose contents are usually unimportant. 745 | c If A is close to a singular matrix, then Z is 746 | c an approximate null vector in the sense that 747 | c norm(A*Z) = RCOND*norm(A)*norm(Z) . 748 | 749 | c ------------------------------------------------------------------ 750 | 751 | c .. Scalar Arguments .. 752 | 753 | INTEGER LDA, N 754 | REAL RCOND 755 | c .. 756 | c .. Array Arguments .. 757 | 758 | INTEGER IPVT( * ) 759 | REAL A( LDA, * ), Z( * ) 760 | c .. 761 | c .. Local Scalars .. 762 | 763 | INTEGER INFO, J, K, KB, KP1, L 764 | REAL ANORM, EK, S, SM, T, WK, WKM, YNORM 765 | c .. 766 | c .. External Functions .. 767 | 768 | REAL SASUM, SDOT 769 | EXTERNAL SASUM, SDOT 770 | c .. 771 | c .. External Subroutines .. 772 | 773 | EXTERNAL SAXPY, SGEFA, SSCAL 774 | c .. 775 | c .. Intrinsic Functions .. 776 | 777 | INTRINSIC ABS, MAX, SIGN 778 | c .. 779 | 780 | 781 | c ** compute 1-norm of A 782 | ANORM = 0.0E0 783 | DO 10 J = 1, N 784 | ANORM = MAX( ANORM, SASUM( N,A( 1,J ),1 ) ) 785 | 10 CONTINUE 786 | c ** factor 787 | 788 | CALL SGEFA( A, LDA, N, IPVT, INFO ) 789 | 790 | c RCOND = 1/(norm(A)*(estimate of norm(inverse(A)))) . 791 | c estimate = norm(Z)/norm(Y) where A*Z = Y and trans(A)*Y = E . 792 | c trans(A) is the transpose of A. The components of E are 793 | c chosen to cause maximum local growth in the elements of W where 794 | c trans(U)*W = E. The vectors are frequently rescaled to avoid 795 | c overflow. 796 | 797 | c ** solve trans(U)*W = E 798 | EK = 1.0E0 799 | 800 | DO 20 J = 1, N 801 | Z( J ) = 0.0E0 802 | 20 CONTINUE 803 | 804 | 805 | DO 50 K = 1, N 806 | 807 | IF( Z( K ).NE.0.0E0 ) EK = SIGN( EK, -Z( K ) ) 808 | 809 | IF( ABS( EK - Z( K ) ).GT.ABS( A( K,K ) ) ) THEN 810 | 811 | S = ABS( A( K,K ) ) / ABS( EK - Z( K ) ) 812 | 813 | CALL SSCAL( N, S, Z, 1 ) 814 | 815 | EK = S*EK 816 | 817 | END IF 818 | 819 | WK = EK - Z( K ) 820 | WKM = -EK - Z( K ) 821 | S = ABS( WK ) 822 | SM = ABS( WKM ) 823 | 824 | IF( A( K,K ).NE.0.0E0 ) THEN 825 | 826 | WK = WK / A( K, K ) 827 | WKM = WKM / A( K, K ) 828 | 829 | ELSE 830 | 831 | WK = 1.0E0 832 | WKM = 1.0E0 833 | 834 | END IF 835 | 836 | KP1 = K + 1 837 | 838 | IF( KP1.LE.N ) THEN 839 | 840 | DO 30 J = KP1, N 841 | SM = SM + ABS( Z( J ) + WKM*A( K,J ) ) 842 | Z( J ) = Z( J ) + WK*A( K, J ) 843 | S = S + ABS( Z( J ) ) 844 | 30 CONTINUE 845 | 846 | IF( S.LT.SM ) THEN 847 | 848 | T = WKM - WK 849 | WK = WKM 850 | 851 | DO 40 J = KP1, N 852 | Z( J ) = Z( J ) + T*A( K, J ) 853 | 40 CONTINUE 854 | 855 | END IF 856 | 857 | END IF 858 | 859 | Z( K ) = WK 860 | 861 | 50 CONTINUE 862 | 863 | 864 | S = 1.0E0 / SASUM( N, Z, 1 ) 865 | 866 | CALL SSCAL( N, S, Z, 1 ) 867 | c ** solve trans(L)*Y = W 868 | DO 60 KB = 1, N 869 | K = N + 1 - KB 870 | 871 | IF( K.LT.N ) 872 | & Z( K ) = Z( K ) + SDOT( N - K, A( K+1, K ), 1, Z( K+1 ), 1) 873 | 874 | IF( ABS( Z( K ) ).GT.1.0E0 ) THEN 875 | 876 | S = 1.0E0 / ABS( Z( K ) ) 877 | 878 | CALL SSCAL( N, S, Z, 1 ) 879 | 880 | END IF 881 | 882 | L = IPVT( K ) 883 | T = Z( L ) 884 | Z( L ) = Z( K ) 885 | Z( K ) = T 886 | 60 CONTINUE 887 | 888 | 889 | S = 1.0E0 / SASUM( N, Z, 1 ) 890 | 891 | CALL SSCAL( N, S, Z, 1 ) 892 | c ** solve L*V = Y 893 | YNORM = 1.0E0 894 | 895 | DO 70 K = 1, N 896 | L = IPVT( K ) 897 | T = Z( L ) 898 | Z( L ) = Z( K ) 899 | Z( K ) = T 900 | 901 | IF( K.LT.N ) CALL SAXPY( N - K, T, A( K + 1,K ), 1, Z( K + 1 ), 902 | & 1 ) 903 | 904 | IF( ABS( Z( K ) ).GT.1.0E0 ) THEN 905 | 906 | S = 1.0E0 / ABS( Z( K ) ) 907 | 908 | CALL SSCAL( N, S, Z, 1 ) 909 | 910 | YNORM = S*YNORM 911 | END IF 912 | 913 | 70 CONTINUE 914 | 915 | 916 | S = 1.0E0 / SASUM( N, Z, 1 ) 917 | 918 | CALL SSCAL( N, S, Z, 1 ) 919 | c ** solve U*Z = V 920 | YNORM = S*YNORM 921 | 922 | DO 80 KB = 1, N 923 | 924 | K = N + 1 - KB 925 | 926 | IF( ABS( Z( K ) ).GT.ABS( A( K,K ) ) ) THEN 927 | 928 | S = ABS( A( K,K ) ) / ABS( Z( K ) ) 929 | 930 | CALL SSCAL( N, S, Z, 1 ) 931 | 932 | YNORM = S*YNORM 933 | 934 | END IF 935 | 936 | IF( A( K,K ).NE.0.0E0 ) Z( K ) = Z( K ) / A( K, K ) 937 | 938 | IF( A( K,K ).EQ.0.0E0 ) Z( K ) = 1.0E0 939 | 940 | T = -Z( K ) 941 | 942 | CALL SAXPY( K - 1, T, A( 1,K ), 1, Z( 1 ), 1 ) 943 | 944 | 80 CONTINUE 945 | c ** make znorm = 1.0 946 | S = 1.0E0 / SASUM( N, Z, 1 ) 947 | 948 | CALL SSCAL( N, S, Z, 1 ) 949 | 950 | YNORM = S*YNORM 951 | 952 | IF( ANORM.NE.0.0E0 ) RCOND = YNORM / ANORM 953 | IF( ANORM.EQ.0.0E0 ) RCOND = 0.0E0 954 | 955 | END 956 | 957 | SUBROUTINE SGEFA( A, LDA, N, IPVT, INFO ) 958 | 959 | c Factors a real matrix by Gaussian elimination. 960 | 961 | c Revision date: 8/1/82 962 | c Author: Moler, C. B. (U. of New Mexico) 963 | 964 | c SGEFA is usually called by SGECO, but it can be called 965 | c directly with a saving in time if RCOND is not needed. 966 | c (time for SGECO) = (1 + 9/N) * (time for SGEFA) . 967 | 968 | c Input: same as SGECO 969 | 970 | c On return: 971 | 972 | c A,IPVT same as SGECO 973 | 974 | c INFO INTEGER 975 | c = 0 normal value. 976 | c = k if u(k,k) .eq. 0.0 . This is not an error 977 | c condition for this subroutine, but it does 978 | c indicate that SGESL or SGEDI will divide by zero 979 | c if called. Use RCOND in SGECO for a reliable 980 | c indication of singularity. 981 | 982 | c --------------------------------------------------------------------- 983 | 984 | c .. Scalar Arguments .. 985 | 986 | INTEGER INFO, LDA, N 987 | c .. 988 | c .. Array Arguments .. 989 | 990 | INTEGER IPVT( * ) 991 | REAL A( LDA, * ) 992 | c .. 993 | c .. Local Scalars .. 994 | 995 | INTEGER J, K, KP1, L, NM1 996 | REAL T 997 | c .. 998 | c .. External Functions .. 999 | 1000 | INTEGER ISAMAX 1001 | EXTERNAL ISAMAX 1002 | c .. 1003 | c .. External Subroutines .. 1004 | 1005 | EXTERNAL SAXPY, SSCAL 1006 | c .. 1007 | 1008 | 1009 | c ** Gaussian elimination with partial pivoting 1010 | INFO = 0 1011 | NM1 = N - 1 1012 | 1013 | DO 20 K = 1, NM1 1014 | 1015 | KP1 = K + 1 1016 | c ** find L = pivot index 1017 | 1018 | L = ISAMAX( N - K + 1, A( K,K ), 1 ) + K - 1 1019 | IPVT( K ) = L 1020 | 1021 | IF( A( L,K ).EQ.0.0E0 ) THEN 1022 | c ** zero pivot implies this column 1023 | c ** already triangularized 1024 | INFO = K 1025 | 1026 | ELSE 1027 | c ** interchange if necessary 1028 | IF( L.NE.K ) THEN 1029 | 1030 | T = A( L, K ) 1031 | A( L, K ) = A( K, K ) 1032 | A( K, K ) = T 1033 | 1034 | END IF 1035 | c ** compute multipliers 1036 | T = -1.0E0 / A( K, K ) 1037 | 1038 | CALL SSCAL( N - K, T, A( K + 1,K ), 1 ) 1039 | 1040 | c ** row elimination with column indexing 1041 | DO 10 J = KP1, N 1042 | 1043 | T = A( L, J ) 1044 | 1045 | IF( L.NE.K ) THEN 1046 | 1047 | A( L, J ) = A( K, J ) 1048 | A( K, J ) = T 1049 | 1050 | END IF 1051 | 1052 | CALL SAXPY( N-K, T, A( K+1, K ), 1, A( K+1, J ), 1 ) 1053 | 1054 | 10 CONTINUE 1055 | 1056 | END IF 1057 | 1058 | 20 CONTINUE 1059 | 1060 | 1061 | IPVT( N ) = N 1062 | IF( A( N,N ) .EQ. 0.0E0 ) INFO = N 1063 | 1064 | END 1065 | 1066 | SUBROUTINE SGESL( A, LDA, N, IPVT, B, JOB ) 1067 | 1068 | c Solves the real system 1069 | c A * X = B or transpose(A) * X = B 1070 | c using the factors computed by SGECO or SGEFA. 1071 | 1072 | c Revision date: 8/1/82 1073 | c Author: Moler, C. B. (U. of New Mexico) 1074 | 1075 | c On entry 1076 | 1077 | c A REAL(LDA, N) 1078 | c the output from SGECO or SGEFA. 1079 | 1080 | c LDA INTEGER 1081 | c the leading dimension of the array A 1082 | 1083 | c N INTEGER 1084 | c the order of the matrix A 1085 | 1086 | c IPVT INTEGER(N) 1087 | c the pivot vector from SGECO or SGEFA. 1088 | 1089 | c B REAL(N) 1090 | c the right hand side vector. 1091 | 1092 | c JOB INTEGER 1093 | c = 0 to solve A*X = B , 1094 | c = nonzero to solve transpose(A)*X = B 1095 | 1096 | c On return 1097 | 1098 | c B the solution vector X 1099 | 1100 | c Error condition 1101 | 1102 | c A division by zero will occur if the input factor contains a 1103 | c zero on the diagonal. Technically, this indicates singularity, 1104 | c but it is often caused by improper arguments or improper 1105 | c setting of LDA. It will not occur if the subroutines are 1106 | c called correctly and if SGECO has set RCOND .GT. 0.0 1107 | c or SGEFA has set INFO .EQ. 0 . 1108 | 1109 | c To compute inverse(a) * c where c is a matrix 1110 | c with p columns 1111 | c call sgeco(a,lda,n,ipvt,rcond,z) 1112 | c if (rcond is too small) go to ... 1113 | c do 10 j = 1, p 1114 | c call sgesl(a,lda,n,ipvt,c(1,j),0) 1115 | c 10 continue 1116 | 1117 | c --------------------------------------------------------------------- 1118 | 1119 | c .. Scalar Arguments .. 1120 | 1121 | INTEGER JOB, LDA, N 1122 | c .. 1123 | c .. Array Arguments .. 1124 | 1125 | INTEGER IPVT( * ) 1126 | REAL A( LDA, * ), B( * ) 1127 | c .. 1128 | c .. Local Scalars .. 1129 | 1130 | INTEGER K, KB, L, NM1 1131 | REAL T 1132 | c .. 1133 | c .. External Functions .. 1134 | 1135 | REAL SDOT 1136 | EXTERNAL SDOT 1137 | c .. 1138 | c .. External Subroutines .. 1139 | 1140 | EXTERNAL SAXPY 1141 | c .. 1142 | 1143 | 1144 | NM1 = N - 1 1145 | 1146 | IF( JOB.EQ.0 ) THEN 1147 | c ** solve A * X = B 1148 | 1149 | c ** first solve L*Y = B 1150 | DO 10 K = 1, NM1 1151 | 1152 | L = IPVT( K ) 1153 | T = B( L ) 1154 | 1155 | IF( L.NE.K ) THEN 1156 | 1157 | B( L ) = B( K ) 1158 | B( K ) = T 1159 | 1160 | END IF 1161 | 1162 | CALL SAXPY( N - K, T, A( K+1, K ), 1, B( K+1 ), 1 ) 1163 | 1164 | 10 CONTINUE 1165 | c ** now solve U*X = Y 1166 | DO 20 KB = 1, N 1167 | 1168 | K = N + 1 - KB 1169 | B( K ) = B( K ) / A( K, K ) 1170 | T = - B( K ) 1171 | 1172 | CALL SAXPY( K-1, T, A( 1, K ), 1, B(1), 1 ) 1173 | 1174 | 20 CONTINUE 1175 | 1176 | 1177 | ELSE 1178 | c ** solve trans(A) * X = B 1179 | 1180 | c ** first solve trans(U)*Y = B 1181 | DO 30 K = 1, N 1182 | 1183 | T = SDOT( K - 1, A( 1,K ), 1, B( 1 ), 1 ) 1184 | B( K ) = ( B( K ) - T ) / A( K, K ) 1185 | 1186 | 30 CONTINUE 1187 | 1188 | c ** now solve trans(l)*x = y 1189 | DO 40 KB = 1, NM1 1190 | 1191 | K = N - KB 1192 | B( K ) = B( K ) + SDOT( N - K, A( K+1, K ), 1, B( K+1 ), 1) 1193 | L = IPVT( K ) 1194 | 1195 | IF( L.NE.K ) THEN 1196 | 1197 | T = B( L ) 1198 | B( L ) = B( K ) 1199 | B( K ) = T 1200 | 1201 | END IF 1202 | 1203 | 40 CONTINUE 1204 | 1205 | END IF 1206 | 1207 | END 1208 | 1209 | REAL FUNCTION SASUM( N, SX, INCX ) 1210 | 1211 | c INPUT-- N Number of elements in vector to be summed 1212 | c SX Sing-prec array, length 1+(N-1)*INCX, containing vector 1213 | c INCX Spacing of vector elements in SX 1214 | 1215 | c OUTPUT-- SASUM Sum from 0 to N-1 of ABS(SX(1+I*INCX)) 1216 | c ---------------------------------------------------------- 1217 | 1218 | c .. Scalar Arguments .. 1219 | 1220 | INTEGER INCX, N 1221 | c .. 1222 | c .. Array Arguments .. 1223 | 1224 | REAL SX( * ) 1225 | c .. 1226 | c .. Local Scalars .. 1227 | 1228 | INTEGER I, M 1229 | c .. 1230 | c .. Intrinsic Functions .. 1231 | 1232 | INTRINSIC ABS, MOD 1233 | c .. 1234 | 1235 | SASUM = 0.0 1236 | 1237 | IF( N.LE.0 ) RETURN 1238 | 1239 | IF( INCX.NE.1 ) THEN 1240 | c ** non-unit increments 1241 | DO 10 I = 1, 1 + ( N - 1 )*INCX, INCX 1242 | SASUM = SASUM + ABS( SX( I ) ) 1243 | 10 CONTINUE 1244 | 1245 | ELSE 1246 | c ** unit increments 1247 | M = MOD( N, 6 ) 1248 | 1249 | IF( M.NE.0 ) THEN 1250 | c ** clean-up loop so remaining vector 1251 | c ** length is a multiple of 6. 1252 | DO 20 I = 1, M 1253 | SASUM = SASUM + ABS( SX( I ) ) 1254 | 20 CONTINUE 1255 | 1256 | END IF 1257 | c ** unroll loop for speed 1258 | DO 30 I = M + 1, N, 6 1259 | SASUM = SASUM + ABS( SX( I ) ) + ABS( SX( I + 1 ) ) + 1260 | & ABS( SX( I + 2 ) ) + ABS( SX( I + 3 ) ) + 1261 | & ABS( SX( I + 4 ) ) + ABS( SX( I + 5 ) ) 1262 | 30 CONTINUE 1263 | 1264 | END IF 1265 | 1266 | END 1267 | 1268 | SUBROUTINE SAXPY( N, SA, SX, INCX, SY, INCY ) 1269 | 1270 | c Y = A*X + Y (X, Y = vectors, A = scalar) 1271 | 1272 | c INPUT-- 1273 | c N Number of elements in input vectors X and Y 1274 | c SA Single precision scalar multiplier A 1275 | c SX Sing-prec array containing vector X 1276 | c INCX Spacing of elements of vector X in SX 1277 | c SY Sing-prec array containing vector Y 1278 | c INCY Spacing of elements of vector Y in SY 1279 | 1280 | c OUTPUT-- 1281 | c SY For I = 0 to N-1, overwrite SY(LY+I*INCY) with 1282 | c SA*SX(LX+I*INCX) + SY(LY+I*INCY), 1283 | c where LX = 1 if INCX .GE. 0, 1284 | c = (-INCX)*N if INCX .LT. 0 1285 | c and LY is defined analogously using INCY. 1286 | c ------------------------------------------------------------ 1287 | 1288 | c .. Scalar Arguments .. 1289 | 1290 | INTEGER INCX, INCY, N 1291 | REAL SA 1292 | c .. 1293 | c .. Array Arguments .. 1294 | 1295 | REAL SX( * ), SY( * ) 1296 | c .. 1297 | c .. Local Scalars .. 1298 | 1299 | INTEGER I, IX, IY, M 1300 | c .. 1301 | c .. Intrinsic Functions .. 1302 | 1303 | INTRINSIC MOD 1304 | c .. 1305 | 1306 | 1307 | IF( N.LE.0 .OR. SA.EQ.0.0 ) RETURN 1308 | 1309 | IF( INCX.EQ.INCY .AND. INCX.GT.1 ) THEN 1310 | 1311 | DO 10 I = 1, 1 + ( N - 1 )*INCX, INCX 1312 | SY( I ) = SY( I ) + SA*SX( I ) 1313 | 10 CONTINUE 1314 | 1315 | ELSE IF( INCX.EQ.INCY .AND. INCX.EQ.1 ) THEN 1316 | 1317 | c ** equal, unit increments 1318 | M = MOD( N, 4 ) 1319 | 1320 | IF( M.NE.0 ) THEN 1321 | c ** clean-up loop so remaining vector length 1322 | c ** is a multiple of 4. 1323 | DO 20 I = 1, M 1324 | SY( I ) = SY( I ) + SA*SX( I ) 1325 | 20 CONTINUE 1326 | 1327 | END IF 1328 | c ** unroll loop for speed 1329 | DO 30 I = M + 1, N, 4 1330 | SY( I ) = SY( I ) + SA*SX( I ) 1331 | SY( I + 1 ) = SY( I + 1 ) + SA*SX( I + 1 ) 1332 | SY( I + 2 ) = SY( I + 2 ) + SA*SX( I + 2 ) 1333 | SY( I + 3 ) = SY( I + 3 ) + SA*SX( I + 3 ) 1334 | 30 CONTINUE 1335 | 1336 | 1337 | ELSE 1338 | c ** nonequal or nonpositive increments. 1339 | IX = 1 1340 | IY = 1 1341 | IF( INCX.LT.0 ) IX = 1 + ( N - 1 )*( -INCX ) 1342 | IF( INCY.LT.0 ) IY = 1 + ( N - 1 )*( -INCY ) 1343 | 1344 | DO 40 I = 1, N 1345 | SY( IY ) = SY( IY ) + SA*SX( IX ) 1346 | IX = IX + INCX 1347 | IY = IY + INCY 1348 | 40 CONTINUE 1349 | 1350 | END IF 1351 | 1352 | END 1353 | 1354 | REAL FUNCTION SDOT( N, SX, INCX, SY, INCY ) 1355 | 1356 | c Single-prec dot product of vectors X and Y 1357 | 1358 | c INPUT-- 1359 | c N Number of elements in input vectors X and Y 1360 | c SX Sing-prec array containing vector X 1361 | c INCX Spacing of elements of vector X in SX 1362 | c SY Sing-prec array containing vector Y 1363 | c INCY Spacing of elements of vector Y in SY 1364 | 1365 | c OUTPUT-- 1366 | c SDOT Sum for I = 0 to N-1 of SX(LX+I*INCX) * SY(LY+I*INCY), 1367 | c where LX = 1 if INCX .GE. 0, 1368 | c = (-INCX)*N if INCX .LT. 0, 1369 | c and LY is defined analogously using INCY. 1370 | c ------------------------------------------------------------------ 1371 | 1372 | c .. Scalar Arguments .. 1373 | 1374 | INTEGER INCX, INCY, N 1375 | c .. 1376 | c .. Array Arguments .. 1377 | 1378 | REAL SX( * ), SY( * ) 1379 | c .. 1380 | c .. Local Scalars .. 1381 | 1382 | INTEGER I, IX, IY, M 1383 | c .. 1384 | c .. Intrinsic Functions .. 1385 | 1386 | INTRINSIC MOD 1387 | c .. 1388 | 1389 | 1390 | SDOT = 0.0 1391 | 1392 | IF( N.LE.0 ) RETURN 1393 | 1394 | IF( INCX.EQ.INCY .AND. INCX.GT.1 ) THEN 1395 | 1396 | DO 10 I = 1, 1 + ( N - 1 )*INCX, INCX 1397 | SDOT = SDOT + SX( I )*SY( I ) 1398 | 10 CONTINUE 1399 | 1400 | 1401 | ELSE IF( INCX.EQ.INCY .AND. INCX.EQ.1 ) THEN 1402 | 1403 | c ** equal, unit increments 1404 | M = MOD( N, 5 ) 1405 | 1406 | IF( M.NE.0 ) THEN 1407 | c ** clean-up loop so remaining vector length 1408 | c ** is a multiple of 4. 1409 | DO 20 I = 1, M 1410 | SDOT = SDOT + SX( I )*SY( I ) 1411 | 20 CONTINUE 1412 | 1413 | END IF 1414 | c ** unroll loop for speed 1415 | DO 30 I = M + 1, N, 5 1416 | SDOT = SDOT + SX( I )*SY( I ) + SX( I + 1 )*SY( I + 1 ) + 1417 | & SX( I + 2 )*SY( I + 2 ) + SX( I + 3 )*SY( I + 3 ) + 1418 | & SX( I + 4 )*SY( I + 4 ) 1419 | 30 CONTINUE 1420 | 1421 | ELSE 1422 | c ** nonequal or nonpositive increments. 1423 | IX = 1 1424 | IY = 1 1425 | 1426 | IF( INCX.LT.0 ) IX = 1 + ( N - 1 )*( -INCX ) 1427 | IF( INCY.LT.0 ) IY = 1 + ( N - 1 )*( -INCY ) 1428 | 1429 | DO 40 I = 1, N 1430 | SDOT = SDOT + SX( IX )*SY( IY ) 1431 | IX = IX + INCX 1432 | IY = IY + INCY 1433 | 40 CONTINUE 1434 | 1435 | END IF 1436 | 1437 | END 1438 | 1439 | SUBROUTINE SSCAL( N, SA, SX, INCX ) 1440 | 1441 | c Multiply vector SX by scalar SA 1442 | 1443 | c INPUT-- N Number of elements in vector 1444 | c SA Single precision scale factor 1445 | c SX Sing-prec array, length 1+(N-1)*INCX, containing vector 1446 | c INCX Spacing of vector elements in SX 1447 | 1448 | c OUTPUT-- SX Replace SX(1+I*INCX) with SA * SX(1+I*INCX) 1449 | c for I = 0 to N-1 1450 | c --------------------------------------------------------------------- 1451 | 1452 | c .. Scalar Arguments .. 1453 | 1454 | INTEGER INCX, N 1455 | REAL SA 1456 | c .. 1457 | c .. Array Arguments .. 1458 | 1459 | REAL SX( * ) 1460 | c .. 1461 | c .. Local Scalars .. 1462 | 1463 | INTEGER I, M 1464 | c .. 1465 | c .. Intrinsic Functions .. 1466 | 1467 | INTRINSIC MOD 1468 | c .. 1469 | 1470 | 1471 | IF( N.LE.0 ) RETURN 1472 | 1473 | IF( INCX.NE.1 ) THEN 1474 | 1475 | DO 10 I = 1, 1 + ( N - 1 )*INCX, INCX 1476 | SX( I ) = SA*SX( I ) 1477 | 10 CONTINUE 1478 | 1479 | 1480 | ELSE 1481 | 1482 | M = MOD( N, 5 ) 1483 | 1484 | IF( M.NE.0 ) THEN 1485 | c ** clean-up loop so remaining vector length 1486 | c ** is a multiple of 5. 1487 | DO 20 I = 1, M 1488 | SX( I ) = SA*SX( I ) 1489 | 20 CONTINUE 1490 | 1491 | END IF 1492 | c ** unroll loop for speed 1493 | DO 30 I = M + 1, N, 5 1494 | SX( I ) = SA*SX( I ) 1495 | SX( I + 1 ) = SA*SX( I + 1 ) 1496 | SX( I + 2 ) = SA*SX( I + 2 ) 1497 | SX( I + 3 ) = SA*SX( I + 3 ) 1498 | SX( I + 4 ) = SA*SX( I + 4 ) 1499 | 30 CONTINUE 1500 | 1501 | END IF 1502 | 1503 | END 1504 | 1505 | SUBROUTINE SSWAP( N, SX, INCX, SY, INCY ) 1506 | 1507 | c Interchange s.p vectors X and Y, as follows: 1508 | 1509 | c For I = 0 to N-1, interchange SX(LX+I*INCX) and SY(LY+I*INCY), 1510 | c where LX = 1 if INCX .GE. 0, 1511 | c = (-INCX)*N if INCX .LT. 0 1512 | c and LY is defined analogously using INCY. 1513 | 1514 | 1515 | c INPUT-- 1516 | c N Number of elements in input vectors X and Y 1517 | c SX Sing-prec array containing vector X 1518 | c INCX Spacing of elements of vector X in SX 1519 | c SY Sing-prec array containing vector Y 1520 | c INCY Spacing of elements of vector Y in SY 1521 | 1522 | c OUTPUT-- 1523 | c SX Input vector SY (unchanged if N .LE. 0) 1524 | c SY Input vector SX (unchanged IF N .LE. 0) 1525 | c -------------------------------------------------------------- 1526 | 1527 | c .. Scalar Arguments .. 1528 | 1529 | INTEGER INCX, INCY, N 1530 | c .. 1531 | c .. Array Arguments .. 1532 | 1533 | REAL SX( * ), SY( * ) 1534 | c .. 1535 | c .. Local Scalars .. 1536 | 1537 | INTEGER I, IX, IY, M 1538 | REAL STEMP1, STEMP2, STEMP3 1539 | c .. 1540 | c .. Intrinsic Functions .. 1541 | 1542 | INTRINSIC MOD 1543 | c .. 1544 | 1545 | 1546 | IF( N.LE.0 ) RETURN 1547 | 1548 | IF( INCX.EQ.INCY .AND. INCX.GT.1 ) THEN 1549 | 1550 | DO 10 I = 1, 1 + ( N-1 )*INCX, INCX 1551 | STEMP1 = SX( I ) 1552 | SX( I ) = SY( I ) 1553 | SY( I ) = STEMP1 1554 | 10 CONTINUE 1555 | 1556 | 1557 | ELSE IF( INCX.EQ.INCY .AND. INCX.EQ.1 ) THEN 1558 | 1559 | c ** equal, unit increments 1560 | M = MOD( N, 3 ) 1561 | 1562 | IF( M.NE.0 ) THEN 1563 | c ** clean-up loop so remaining vector length 1564 | c ** is a multiple of 3. 1565 | DO 20 I = 1, M 1566 | STEMP1 = SX( I ) 1567 | SX( I ) = SY( I ) 1568 | SY( I ) = STEMP1 1569 | 20 CONTINUE 1570 | 1571 | END IF 1572 | c ** unroll loop for speed 1573 | DO 30 I = M + 1, N, 3 1574 | STEMP1 = SX( I ) 1575 | STEMP2 = SX( I + 1 ) 1576 | STEMP3 = SX( I + 2 ) 1577 | SX( I ) = SY( I ) 1578 | SX( I + 1 ) = SY( I + 1 ) 1579 | SX( I + 2 ) = SY( I + 2 ) 1580 | SY( I ) = STEMP1 1581 | SY( I + 1 ) = STEMP2 1582 | SY( I + 2 ) = STEMP3 1583 | 30 CONTINUE 1584 | 1585 | 1586 | ELSE 1587 | c ** nonequal or nonpositive increments. 1588 | IX = 1 1589 | IY = 1 1590 | 1591 | IF( INCX.LT.0 ) IX = 1 + ( N - 1 )*( -INCX ) 1592 | IF( INCY.LT.0 ) IY = 1 + ( N - 1 )*( -INCY ) 1593 | 1594 | DO 40 I = 1, N 1595 | STEMP1 = SX( IX ) 1596 | SX( IX ) = SY( IY ) 1597 | SY( IY ) = STEMP1 1598 | IX = IX + INCX 1599 | IY = IY + INCY 1600 | 40 CONTINUE 1601 | 1602 | END IF 1603 | 1604 | END 1605 | 1606 | INTEGER FUNCTION ISAMAX( N, SX, INCX ) 1607 | 1608 | c INPUT-- N Number of elements in vector of interest 1609 | c SX Sing-prec array, length 1+(N-1)*INCX, containing vector 1610 | c INCX Spacing of vector elements in SX 1611 | 1612 | c OUTPUT-- ISAMAX First I, I = 1 to N, to maximize 1613 | c ABS(SX(1+(I-1)*INCX)) 1614 | c --------------------------------------------------------------------- 1615 | 1616 | c .. Scalar Arguments .. 1617 | 1618 | INTEGER INCX, N 1619 | c .. 1620 | c .. Array Arguments .. 1621 | 1622 | REAL SX( * ) 1623 | c .. 1624 | c .. Local Scalars .. 1625 | 1626 | INTEGER I, II 1627 | REAL SMAX, XMAG 1628 | c .. 1629 | c .. Intrinsic Functions .. 1630 | 1631 | INTRINSIC ABS 1632 | c .. 1633 | 1634 | 1635 | IF( N.LE.0 ) THEN 1636 | 1637 | ISAMAX = 0 1638 | 1639 | ELSE IF( N.EQ.1 ) THEN 1640 | 1641 | ISAMAX = 1 1642 | 1643 | ELSE 1644 | 1645 | SMAX = 0.0 1646 | II = 1 1647 | 1648 | DO 10 I = 1, 1 + ( N-1 )*INCX, INCX 1649 | 1650 | XMAG = ABS( SX( I ) ) 1651 | 1652 | IF( SMAX.LT.XMAG ) THEN 1653 | 1654 | SMAX = XMAG 1655 | ISAMAX = II 1656 | 1657 | END IF 1658 | 1659 | II = II + 1 1660 | 1661 | 10 CONTINUE 1662 | 1663 | END IF 1664 | 1665 | END 1666 | 1667 | -------------------------------------------------------------------------------- /src/disort/src/PRTFIN.f: -------------------------------------------------------------------------------- 1 | SUBROUTINE PRTFIN( UTAU, NTAU, UMU, NUMU, PHI, NPHI, MAXULV, 2 | & MAXUMU, ONLYFL, RFLDIR, RFLDN, FLUP, DFDT, 3 | & UU, TSTFIR, TSTFDN, TSTFUP, TSTDFD, TSTUU, 4 | & MAXTAU, MAXMU, MAXAZ ) 5 | 6 | c Print DISORT results and, directly beneath them, their 7 | c ratios to the correct answers; print number of non-unit 8 | c ratios that occur but try to count just the cases where 9 | c there is a real disagreement and not those where flux or 10 | c intensity are down at their noise level (defined as 10^(-6) 11 | c times their maximum value). d(flux)/d(tau) is treated the 12 | c same as fluxes in this noise estimation even though it 13 | c is a different type of quantity (although with flux units). 14 | 15 | c INPUT : TSTFIR correct direct flux 16 | c TSTFDN correct diffuse down flux 17 | c TSTFUP correct diffuse up flux 18 | c TSTDFD correct d(flux)/d(optical depth) 19 | c TSTUU correct intensity 20 | c (remaining input = DISORT I/O variables) 21 | 22 | c -------------------------------------------------------------------- 23 | 24 | c .. Parameters .. 25 | 26 | INTEGER MAXRAT 27 | PARAMETER ( MAXRAT = 100 ) 28 | c .. 29 | c .. Scalar Arguments .. 30 | 31 | LOGICAL ONLYFL 32 | INTEGER MAXAZ, MAXMU, MAXTAU, MAXULV, MAXUMU, NPHI, NTAU, NUMU 33 | c .. 34 | c .. Array Arguments .. 35 | 36 | REAL DFDT( * ), FLUP( * ), PHI( * ), RFLDIR( * ), RFLDN( * ), 37 | & TSTDFD( * ), TSTFDN( * ), TSTFIR( * ), TSTFUP( * ), 38 | & TSTUU( MAXTAU, MAXMU, MAXAZ ), UMU( * ), UTAU( * ), 39 | & UU( MAXUMU, MAXULV, * ) 40 | c .. 41 | c .. Local Scalars .. 42 | 43 | INTEGER IU, J, LU, NUMBAD 44 | REAL FLXMAX, FNOISE, RAT, RAT1, RAT2, RAT3, RAT4, UMAX, UNOISE 45 | c .. 46 | c .. Local Arrays .. 47 | 48 | REAL RATV( MAXRAT ) 49 | c .. 50 | c .. External Functions .. 51 | 52 | REAL RATIO 53 | EXTERNAL RATIO 54 | c .. 55 | c .. External Subroutines .. 56 | 57 | EXTERNAL ERRMSG 58 | c .. 59 | c .. Statement Functions .. 60 | 61 | LOGICAL BADRAT 62 | c .. 63 | c .. Statement Function definitions .. 64 | 65 | BADRAT( RAT ) = (RAT.LT.0.99) .OR. (RAT.GT.1.01) 66 | c .. 67 | 68 | 69 | IF ( NTAU.GT.MAXTAU .OR. NUMU.GT.MAXMU .OR. NPHI.GT.MAXAZ ) CALL 70 | & ERRMSG( 'PRTFIN--out of bounds in comparator arrays', .TRUE.) 71 | 72 | FLXMAX = 0.0 73 | DO 5 LU = 1, NTAU 74 | FLXMAX = MAX( FLXMAX, TSTFIR(LU), TSTFDN(LU), TSTFUP(LU) ) 75 | 5 CONTINUE 76 | FNOISE = 1.E-6 * FLXMAX 77 | IF( FLXMAX.LE.0.0 ) 78 | & CALL ERRMSG( 'PRTFIN--all fluxes zero or negative', .FALSE.) 79 | IF( FNOISE.LE.0.0 ) 80 | & CALL ERRMSG( 'PRTFIN--all fluxes near underflowing', .FALSE.) 81 | 82 | NUMBAD = 0 83 | 84 | WRITE(*,'(//,A,/,A,/,A)') 85 | & ' <-------------- FLUXES -------------->', 86 | & ' Optical Downward Downward Upward'// 87 | & ' d(Net Flux)', 88 | & ' Depth Direct Diffuse Diffuse'// 89 | & ' / d(Op Dep)' 90 | 91 | DO 10 LU = 1, NTAU 92 | 93 | WRITE( *,'(0P,F11.4,1P,4E15.4)') UTAU(LU), RFLDIR(LU), 94 | & RFLDN(LU), FLUP(LU), DFDT(LU) 95 | RAT1 = RATIO( RFLDIR(LU), TSTFIR(LU) ) 96 | RAT2 = RATIO( RFLDN(LU), TSTFDN(LU) ) 97 | RAT3 = RATIO( FLUP(LU), TSTFUP(LU) ) 98 | RAT4 = RATIO( DFDT(LU), TSTDFD(LU) ) 99 | WRITE( *,'(11X,4( '' ('',F9.4,'')''))') 100 | & RAT1, RAT2, RAT3, RAT4 101 | 102 | IF( BADRAT(RAT1) .AND. ABS(RFLDIR(LU)).GT.FNOISE ) 103 | & NUMBAD = NUMBAD+1 104 | IF( BADRAT(RAT2) .AND. ABS(RFLDN(LU)).GT.FNOISE ) 105 | & NUMBAD = NUMBAD+1 106 | IF( BADRAT(RAT3) .AND. ABS(FLUP(LU)).GT.FNOISE ) 107 | & NUMBAD = NUMBAD+1 108 | IF( BADRAT(RAT4) .AND. ABS(DFDT(LU)).GT.FNOISE ) 109 | & NUMBAD = NUMBAD+1 110 | 111 | 10 CONTINUE 112 | 113 | 114 | IF ( ONLYFL ) GO TO 100 115 | 116 | IF ( NUMU.GT.MAXRAT .OR. NPHI.GT.MAXRAT ) 117 | & CALL ERRMSG( 'PRTFIN--increase parameter MAXRAT', .TRUE.) 118 | 119 | 120 | c ** Print intensities 121 | 122 | IF ( NPHI.GT.8 ) CALL ERRMSG 123 | & ( 'PRTFIN--intensity FORMATs inadequate',.FALSE.) 124 | 125 | UMAX = 0.0 126 | DO 36 LU = 1, NTAU 127 | DO 35 IU = 1, NUMU 128 | DO 34 J = 1, NPHI 129 | UMAX = MAX( UMAX, TSTUU(LU,IU,J) ) 130 | 34 CONTINUE 131 | 35 CONTINUE 132 | 36 CONTINUE 133 | UNOISE = 1.E-6 * UMAX 134 | IF( UMAX.LE.0.0 ) CALL ERRMSG 135 | & ( 'PRTFIN--all intensities zero or negative',.FALSE.) 136 | IF( UNOISE.LE.0.0 ) CALL ERRMSG 137 | & ( 'PRTFIN--all intensities near underflowing',.FALSE.) 138 | 139 | WRITE( *,'(//,A,//,A,/,A,/,A,8(F10.1,4X))' ) 140 | & ' ******** I N T E N S I T I E S *********', 141 | & ' Polar Azimuthal Angles (Degrees)', 142 | & ' Optical Angle', 143 | & ' Depth Cosine', ( PHI(J), J = 1, NPHI ) 144 | 145 | DO 60 LU = 1, NTAU 146 | 147 | DO 50 IU = 1, NUMU 148 | 149 | IF( IU.EQ.1 ) WRITE( *,'(/,0P,F10.3,F8.3,1P,8E14.4)') 150 | & UTAU(LU), UMU(IU), ( UU( IU,LU,J ), J = 1, NPHI ) 151 | 152 | IF( IU.GT.1 ) WRITE( *,'(10X,0P,F8.3, 1P,8E14.4)') 153 | & UMU(IU), ( UU( IU,LU,J ), J = 1, NPHI ) 154 | 155 | DO 40 J = 1, NPHI 156 | RATV(J) = RATIO( UU(IU,LU,J), TSTUU(LU,IU,J) ) 157 | IF( BADRAT(RATV(J)) .AND. ABS(UU(IU,LU,J)).GT.UNOISE ) 158 | & NUMBAD = NUMBAD + 1 159 | 40 CONTINUE 160 | 161 | WRITE( *,'(18X, 8(:,'' ('',F9.4,'')''))') 162 | & ( RATV(J), J = 1, NPHI ) 163 | 164 | 50 CONTINUE 165 | 60 CONTINUE 166 | 167 | 100 CONTINUE 168 | IF( NUMBAD.GT.0 ) WRITE( *,300) ' ==== ', NUMBAD, 169 | & ' SERIOUSLY NON-UNIT RATIOS ====' 170 | 171 | RETURN 172 | 173 | 300 FORMAT( //,1X,45('='),/,A,I4,A,/,1X,45('=') ) 174 | END 175 | -------------------------------------------------------------------------------- /src/disort/src/RDI1MACH.f: -------------------------------------------------------------------------------- 1 | c --------------------------------------------------------------------- 2 | c Fortran-90 versions of machine-constant routines R1MACH, D1MACH, I1MACH 3 | c 4 | c {R,D,I}1MACH revisited: no more uncommenting DATA statements 5 | c 6 | c Presented at the IFIP WG 2.5 International Workshop on 7 | c "Current Directions in Numerical Software and High Performance 8 | c Computing", 19 - 20 October 1995, Kyoto, Japan. 9 | c 10 | c The widely-used original routines were modified to use Fortran-90 11 | c intrinsic functions. This was not completely possible with I1MACH, 12 | c which returns some parameters (logical unit numbers of standard 13 | c input, standard output, and standard error) that may require 14 | c user customization. 15 | c 16 | c David Gay (dmg@bell-labs.com) 17 | c Eric Grosse (ehg@bell-labs.com) 18 | c Bell Laboratories 19 | c 700 Mountain Avenue 20 | c Murray Hill, New Jersey 07974-0636 21 | c USA 22 | c 23 | c References: 24 | c 25 | c David Gay and Eric Grosse, Comment on Algorithm 528, Bell Labs, Murray 26 | c Hill, NJ. submitted to ACM Transactions on Mathematical Software, 27 | c August 1996. 28 | c 29 | c http://www.nsc.liu.se/~boein/ifip/kyoto/workshop-info/proceedings/einarsson 30 | c /d1mach.html (THIS WEB SITE WORKED AS OF APR 2000) 31 | c ------------------------------------------------------------------------- 32 | 33 | 34 | REAL FUNCTION R1MACH (I) 35 | c 36 | c R1MACH can be used to obtain machine-dependent parameters for 37 | c single precision numbers. The results for various values of I are: 38 | c 39 | c R1MACH(1) = B**(EMIN-1), the smallest positive magnitude. 40 | c R1MACH(2) = B**EMAX*(1 - B**(-T)), the largest magnitude. 41 | c R1MACH(3) = B**(-T), the smallest relative spacing. 42 | c R1MACH(4) = B**(1-T), the largest relative spacing. 43 | c R1MACH(5) = LOG10(B) 44 | c 45 | c Assume single precision numbers are represented in the T-digit, 46 | c base-B form 47 | c 48 | c sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) ) 49 | c 50 | c where 0 <= X(I) < B for I=1,...,T; 0 < X(1); and EMIN <= E <= EMAX. 51 | c 52 | c The values of B, T, EMIN and EMAX are provided in I1MACH as follows: 53 | c I1MACH(10) = B, the base. 54 | c I1MACH(11) = T, the number of base-B digits. 55 | c I1MACH(12) = EMIN, the smallest exponent E. 56 | c I1MACH(13) = EMAX, the largest exponent E. 57 | c 58 | c***REFERENCES 59 | c 60 | c P. Fox, A. Hall and N. Schryer, Framework for a portable library, 61 | c ACM Transactions on Mathematical Software 4, 177-188 (1978). 62 | c 63 | c David Gay and Eric Grosse, Comment on Algorithm 528, Bell Labs, Murray 64 | c Hill, NJ. submitted to ACM Transactions on Mathematical Software, 65 | c August 1996. 66 | c 67 | c***REVISION HISTORY (YYMMDD) 68 | c 790101 DATE WRITTEN 69 | c 960329 Modified for Fortran 90 (BE after suggestions by Eric Grosse) 70 | c -------------------------------------------------------------------- 71 | 72 | IMPLICIT NONE 73 | INTEGER :: I 74 | REAL :: B, X = 1.0 75 | 76 | B = RADIX(X) 77 | 78 | SELECT CASE (I) 79 | CASE (1) 80 | R1MACH = TINY(X) ! smallest positive magnitude. 81 | CASE (2) 82 | R1MACH = HUGE(X) ! largest magnitude. 83 | CASE (3) 84 | R1MACH = B**(-DIGITS(X)) ! smallest relative spacing. 85 | CASE (4) 86 | R1MACH = B**(1-DIGITS(X)) ! largest relative spacing. 87 | CASE (5) 88 | R1MACH = LOG10(B) 89 | CASE DEFAULT 90 | STOP 'R1MACH -- input argument out of bounds' 91 | END SELECT 92 | 93 | RETURN 94 | END FUNCTION R1MACH 95 | 96 | 97 | DOUBLE PRECISION FUNCTION D1MACH (I) 98 | c 99 | c D1MACH can be used to obtain machine-dependent parameters for 100 | c double precision numbers. The results for various values of I are: 101 | c 102 | c D1MACH(1) = B**(EMIN-1), the smallest positive magnitude. 103 | c D1MACH(2) = B**EMAX*(1 - B**(-T)), the largest magnitude. 104 | c D1MACH(3) = B**(-T), the smallest relative spacing. 105 | c D1MACH(4) = B**(1-T), the largest relative spacing. 106 | c D1MACH(5) = LOG10(B) 107 | c 108 | c Assume double precision numbers are represented in the T-digit, 109 | c base-B form 110 | c 111 | c sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) ) 112 | c 113 | c where 0 <= X(I) < B for I=1,...,T; 0 < X(1); and EMIN <= E <= EMAX. 114 | c 115 | c The values of B, T, EMIN and EMAX are provided in I1MACH as follows: 116 | c I1MACH(10) = B, the base. 117 | c I1MACH(11) = T, the number of base-B digits. 118 | c I1MACH(12) = EMIN, the smallest exponent E. 119 | c I1MACH(13) = EMAX, the largest exponent E. 120 | c 121 | c***REFERENCES 122 | c 123 | c P. Fox, A. Hall and N. Schryer, Framework for a portable library, 124 | c ACM Transactions on Mathematical Software 4, 177-188 (1978). 125 | c 126 | c David Gay and Eric Grosse, Comment on Algorithm 528, Bell Labs, Murray 127 | c Hill, NJ. submitted to ACM Transactions on Mathematical Software, 128 | c August 1996. 129 | c 130 | c***REVISION HISTORY (YYMMDD) 131 | c 790101 DATE WRITTEN 132 | c 960329 Modified for Fortran 90 (BE after suggestions by Eric Grosse) 133 | c -------------------------------------------------------------------- 134 | 135 | IMPLICIT NONE 136 | INTEGER :: I 137 | DOUBLE PRECISION :: B, X = 1.D0 138 | 139 | B = RADIX(X) 140 | 141 | SELECT CASE (I) 142 | CASE (1) 143 | D1MACH = TINY(X) ! smallest positive magnitude. 144 | CASE (2) 145 | D1MACH = HUGE(X) ! largest magnitude. 146 | CASE (3) 147 | D1MACH = B**(-DIGITS(X)) ! smallest relative spacing. 148 | CASE (4) 149 | D1MACH = B**(1-DIGITS(X)) ! largest relative spacing. 150 | CASE (5) 151 | D1MACH = LOG10(B) 152 | CASE DEFAULT 153 | STOP 'D1MACH -- input arg out of bounds' 154 | END SELECT 155 | 156 | RETURN 157 | END FUNCTION D1MACH 158 | 159 | 160 | INTEGER FUNCTION I1MACH (I) 161 | c 162 | c I1MACH can be used to obtain machine-dependent parameters for the 163 | c local machine environment. The results for various values of I are: 164 | c 165 | c I/O unit numbers (**MAY REQUIRE USER CUSTOMIZATION**): 166 | c I1MACH( 1) = the standard input unit. 167 | c I1MACH( 2) = the standard output unit. 168 | c I1MACH( 3) = the standard punch unit (obsolete, will cause error) 169 | c I1MACH( 4) = the standard error message unit. 170 | c (the error message unit is usually 0 in UNIX systems) 171 | c 172 | c Words: 173 | c I1MACH( 5) = the number of bits per integer storage unit. 174 | c I1MACH( 6) = the number of characters per integer storage unit. 175 | c (obsolete, will cause an error) 176 | c 177 | c Integers: 178 | c assume integers are represented in the S-digit, base-A form 179 | c 180 | c sign ( X(S-1)*A**(S-1) + ... + X(1)*A + X(0) ) 181 | c 182 | c where 0 <= X(I) < A for I=0,...,S-1. 183 | c 184 | c I1MACH( 7) = A, the base. 185 | c I1MACH( 8) = S, the number of base-A digits. 186 | c I1MACH( 9) = A**S - 1, the largest magnitude. 187 | c 188 | c Floating-Point Numbers: 189 | c Assume floating-point numbers are represented in the T-digit, 190 | c base-B form 191 | c sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) ) 192 | c 193 | c where 0 <= X(I) .LT. B for I=1,...,T; 0 < X(1); and EMIN <= E <= EMAX. 194 | c 195 | c I1MACH(10) = B, the base. 196 | c 197 | c Single-Precision: 198 | c I1MACH(11) = T, the number of base-B digits. 199 | c I1MACH(12) = EMIN, the smallest exponent E. 200 | c I1MACH(13) = EMAX, the largest exponent E. 201 | c 202 | c Double-Precision: 203 | c I1MACH(14) = T, the number of base-B digits. 204 | c I1MACH(15) = EMIN, the smallest exponent E. 205 | c I1MACH(16) = EMAX, the largest exponent E. 206 | c 207 | c***REFERENCES 208 | c 209 | c P. Fox, A. Hall and N. Schryer, Framework for a portable library, 210 | c ACM Transactions on Mathematical Software 4, 177-188 (1978). 211 | c 212 | c David Gay and Eric Grosse, Comment on Algorithm 528, Bell Labs, Murray 213 | c Hill, NJ. submitted to ACM Transactions on Mathematical Software, 214 | c August 1996. 215 | c 216 | c***REVISION HISTORY (YYMMDD) 217 | c 750101 DATE WRITTEN 218 | c 960411 Modified for Fortran 90 (BE after suggestions by Eric Grosse) 219 | c -------------------------------------------------------------------- 220 | 221 | IMPLICIT NONE 222 | INTEGER :: I 223 | REAL :: X_single = 1.0 224 | DOUBLE PRECISION :: X_double = 1.D0 225 | 226 | SELECT CASE (I) 227 | CASE (1) 228 | I1MACH = 5 ! Input unit 229 | CASE (2) 230 | I1MACH = 6 ! Output unit 231 | CASE (3) 232 | STOP 'I1MACH: input arg = 3 is obsolete' 233 | CASE (4) 234 | I1MACH = 0 ! Error message unit 235 | CASE (5) 236 | I1MACH = BIT_SIZE(I) 237 | CASE (6) 238 | STOP 'I1MACH: input arg = 6 is obsolete' 239 | CASE (7) 240 | I1MACH = RADIX(1) 241 | CASE (8) 242 | I1MACH = BIT_SIZE(I) - 1 243 | CASE (9) 244 | I1MACH = HUGE(1) 245 | CASE (10) 246 | I1MACH = RADIX(X_single) 247 | CASE (11) 248 | I1MACH = DIGITS(X_single) 249 | CASE (12) 250 | I1MACH = MINEXPONENT(X_single) 251 | CASE (13) 252 | I1MACH = MAXEXPONENT(X_single) 253 | CASE (14) 254 | I1MACH = DIGITS(X_double) 255 | CASE (15) 256 | I1MACH = MINEXPONENT(X_double) 257 | CASE (16) 258 | I1MACH = MAXEXPONENT(X_double) 259 | CASE DEFAULT 260 | STOP 'I1MACH: input argument out of bounds' 261 | END SELECT 262 | 263 | RETURN 264 | END FUNCTION I1MACH 265 | 266 | -------------------------------------------------------------------------------- /test/rayleigh_layer_opd.txt: -------------------------------------------------------------------------------- 1 | # Differential Optical Thickness within atmospheric layers (US Standard Atmosphere) 2 | # Wavelength [um]: 0.325880 3 | # Total optical thickness [-]: 0.855166 4 | # Altitude [km]: 0.000 1.000 2.000 3.000 4.000 5.000 6.000 7.000 8.000 9.000 10.000 11.000 12.000 13.000 14.000 15.000 16.000 17.000 18.000 19.000 20.000 21.000 22.000 23.000 24.000 25.000 27.500 30.000 32.500 35.000 37.500 40.000 42.500 45.000 47.500 50.000 55.000 60.000 65.000 70.000 75.000 80.000 85.000 90.000 95.000 100.000 105.000 110.000 115.000 120.000 5 | # base_height tau_layer 6 | 0.0000000 9.63574461E-02 7 | 1.0000000 8.73580055E-02 8 | 2.0000000 7.89928868E-02 9 | 3.0000000 7.12620898E-02 10 | 4.0000000 6.41457921E-02 11 | 5.0000000 5.75845260E-02 12 | 6.0000000 5.15584689E-02 13 | 7.0000000 4.60279757E-02 14 | 8.0000000 4.09514190E-02 15 | 9.0000000 3.63169054E-02 16 | 10.000000 3.20947009E-02 17 | 11.000000 2.79061947E-02 18 | 12.000000 2.38564465E-02 19 | 13.000000 2.03874991E-02 20 | 14.000000 1.74220447E-02 21 | 15.000000 1.48907043E-02 22 | 16.000000 1.27300456E-02 23 | 17.000000 1.08825834E-02 24 | 18.000000 9.30272566E-03 25 | 19.000000 7.95280958E-03 26 | 20.000000 6.78724327E-03 27 | 21.000000 5.78223967E-03 28 | 22.000000 4.92788749E-03 29 | 23.000000 4.20337306E-03 30 | 24.000000 3.58827914E-03 31 | 25.000000 6.92649673E-03 32 | 27.500000 4.69299020E-03 33 | 30.000000 3.14881307E-03 34 | 32.500000 2.12349134E-03 35 | 35.000000 1.48619616E-03 36 | 37.500000 1.02532172E-03 37 | 40.000000 6.99389342E-04 38 | 42.500000 4.90261373E-04 39 | 45.000000 3.47390299E-04 40 | 47.500000 2.50557111E-04 41 | 50.000000 3.28757096E-04 42 | 55.000000 1.80742068E-04 43 | 60.000000 9.72494611E-05 44 | 65.000000 5.06367200E-05 45 | 70.000000 2.53500761E-05 46 | 75.000000 1.20709456E-05 47 | 80.000000 5.49382147E-06 48 | 85.000000 2.40308850E-06 49 | 90.000000 9.97074581E-07 50 | 95.000000 4.07650870E-07 51 | 100.00000 1.67728560E-07 52 | 105.00000 7.11332432E-08 53 | 110.00000 3.08518266E-08 54 | 115.00000 1.46706739E-08 55 | -------------------------------------------------------------------------------- /test/test_Rayleigh.py: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env python 2 | """ 3 | Test of the Python wrapper to the DISORT library 4 | 5 | Module '_disort' is auto-generated with f2py (version:2). 6 | """ 7 | 8 | import numpy as np 9 | from pylab import plt 10 | import disort 11 | 12 | ########################################################################################################## 13 | 14 | if __name__ == '__main__': 15 | 16 | # read Rayleigh optical thickness for 325.8 nm [Ozone fitting window] 17 | xy = np.loadtxt('rayleigh_layer_opd.txt') 18 | dTau = xy[::-1,1] # FROM TOP TO BOTTOM 19 | z_atm = xy[::-1,0] # last altitude value missing, find in header 20 | z_atm = np.insert(z_atm, 0, 120.) 21 | 22 | N_tau = len(dTau) 23 | w0 = np.ones(N_tau)*1. 24 | iphas = np.ones(N_tau,dtype='int')*2 25 | gg = np.zeros(N_tau) 26 | 27 | cumTau = np.hstack([0.,dTau.cumsum()]) 28 | uTau = cumTau 29 | phi = np.array([0.,60.,120.]) 30 | umu0 = 1./np.sqrt(2.) 31 | fbeam = 1./umu0 # Ensures fluxes to be normalized to one 32 | phi0 = 0.0 33 | albedo = 0.1 34 | umu = np.array([-1.,-0.5,0.5,1.]) 35 | prnt = np.array([True, True, True, False, True]) 36 | 37 | [rfldir, rfldn, flup, dfdt, uavg, uu, albmed, trnmed] =\ 38 | disort.run(dTau, w0=w0, iphas=iphas, gg=gg, 39 | umu0=umu0, phi0=phi0, albedo=albedo, fbeam=fbeam, 40 | utau=uTau, umu=umu, phi=phi, prnt=prnt) 41 | 42 | rfltot = rfldir + rfldn 43 | print '\n# Energy conservation, R(TOA)+T(BOA)*(1-albedo) ~ 1: %.3f' % (flup[0] + rfltot[-1]*(1.-albedo)) 44 | 45 | plt.figure() 46 | plt.plot(rfltot, z_atm) 47 | 48 | plt.figure() 49 | plt.plot(flup, z_atm) 50 | -------------------------------------------------------------------------------- /test/test_disort.py: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env python 2 | """ 3 | Test of the Python wrapper to the DISORT library 4 | 5 | Module '_disort' is auto-generated with f2py (version:2). 6 | """ 7 | 8 | import numpy as np 9 | import disort 10 | 11 | ########################################################################################################## 12 | 13 | if __name__ == '__main__': 14 | 15 | uTau = np.array([0.,1.]) 16 | phi = np.array([0.,60.,120.]) 17 | fbeam = 1. 18 | umu0 = 1./np.sqrt(2.) 19 | phi0 = 0.0 20 | albedo = 0.1 21 | umu = np.array([-1.,-0.5,0.5,1.]) 22 | 23 | # dTau = np.ones(50)*1./50 24 | # w0 = np.ones(50)*1. 25 | # iphas = np.ones(50,dtype='int')*2 26 | # gg = np.ones(50)*0.85 27 | 28 | # [rfldir, rfldn, flup, dfdt, uavg, uu, albmed, trnmed] =\ 29 | # disort.run(dTau, w0=w0, iphas=iphas, gg=gg, 30 | # umu0=umu0, phi0=phi0, albedo=albedo, fbeam=fbeam, 31 | # utau=uTau, umu=umu, phi=phi) 32 | 33 | # CASE IMPLEMENTED IN run_disort.f 34 | dTau = np.array([0.0, 0.0, 0.0, 1.0, 0.0, 0.0]) 35 | iphas = np.array([2, 2, 2, 3, 2, 2]) 36 | w0 = np.array([0.5, 0.5, 0.5, 0.899999976, 0.5, 0.5]) 37 | N = len(dTau) 38 | gg = np.ones(N)*0.85 39 | prnt = np.array([True, True, True, False, True]) 40 | 41 | [rfldir, rfldn, flup, dfdt, uavg, uu, albmed, trnmed] =\ 42 | disort.run(dTau, w0=w0, iphas=iphas, gg=gg, 43 | umu0=umu0, phi0=phi0, albedo=albedo, fbeam=fbeam, 44 | utau=uTau, umu=umu, phi=phi, prnt=prnt) 45 | 46 | print '\n\n' 47 | print '########################################### REFERENCE ###############################################' 48 | print '\n\n' 49 | print ' ****************************************************************************************************' 50 | print ' DISORT: Test Case No. 10a: like 9c, USRANG = True ' 51 | print ' ****************************************************************************************************' 52 | print '' 53 | print ' No. streams = 32 No. computational layers = 6' 54 | print ' 2 User optical depths : 0.0000 1.0000' 55 | print ' 4 User polar angle cosines : -1.00000 -0.50000 0.50000 1.00000' 56 | print ' 3 User azimuthal angles : 0.00 60.00 120.00' 57 | print ' No thermal emission' 58 | print ' Boundary condition flag: IBCND = 0' 59 | print ' Incident beam with intensity = 1.000E+00 and polar angle cosine = 0.70711 and azimuth angle = 0.00' 60 | print ' plus isotropic incident intensity = 0.000E+00' 61 | print ' Bottom albedo (Lambertian) = 0.1000' 62 | print ' Uses delta-M method' 63 | print ' Uses TMS/IMS method' 64 | print ' Calculate fluxes and intensities' 65 | print ' Relative convergence criterion for azimuth series = 0.00E+00' 66 | print '' 67 | print ' <------------- Delta-M --------------->' 68 | print ' Total Single Total Single' 69 | print ' Optical Optical Scatter Separated Optical Optical Scatter Asymm' 70 | print ' Depth Depth Albedo Fraction Depth Depth Albedo Factor' 71 | print ' 1 0.0000 0.0000 0.50000 0.00000 0.0000 0.0000 0.50000 0.0000' 72 | print ' 2 0.0000 0.0000 0.50000 0.00000 0.0000 0.0000 0.50000 0.0000' 73 | print ' 3 0.0000 0.0000 0.50000 0.00000 0.0000 0.0000 0.50000 0.0000' 74 | print ' 4 1.0000 1.0000 0.90000 0.00551 0.9950 0.9950 0.89950 0.8500' 75 | print ' 5 0.0000 1.0000 0.50000 0.00000 0.0000 0.9950 0.50000 0.0000' 76 | print ' 6 0.0000 1.0000 0.50000 0.00000 0.0000 0.9950 0.50000 0.0000' 77 | print '' 78 | print ' Number of Phase Function Moments = 33' 79 | print ' Layer Phase Function Moments' 80 | print ' 1 1.000000 0.000000 0.100000 0.000000 0.000000 0.000000 0.000000 0.000000 0.000000 0.000000' 81 | print ' 0.000000 0.000000 0.000000 0.000000 0.000000 0.000000 0.000000 0.000000 0.000000 0.000000' 82 | print ' 0.000000 0.000000 0.000000 0.000000 0.000000 0.000000 0.000000 0.000000 0.000000 0.000000' 83 | print ' 0.000000 0.000000 0.000000' 84 | print ' 2 1.000000 0.000000 0.100000 0.000000 0.000000 0.000000 0.000000 0.000000 0.000000 0.000000' 85 | print ' 0.000000 0.000000 0.000000 0.000000 0.000000 0.000000 0.000000 0.000000 0.000000 0.000000' 86 | print ' 0.000000 0.000000 0.000000 0.000000 0.000000 0.000000 0.000000 0.000000 0.000000 0.000000' 87 | print ' 0.000000 0.000000 0.000000' 88 | print ' 3 1.000000 0.000000 0.100000 0.000000 0.000000 0.000000 0.000000 0.000000 0.000000 0.000000' 89 | print ' 0.000000 0.000000 0.000000 0.000000 0.000000 0.000000 0.000000 0.000000 0.000000 0.000000' 90 | print ' 0.000000 0.000000 0.000000 0.000000 0.000000 0.000000 0.000000 0.000000 0.000000 0.000000' 91 | print ' 0.000000 0.000000 0.000000' 92 | print ' 4 1.000000 0.850000 0.722500 0.614125 0.522006 0.443705 0.377150 0.320577 0.272491 0.231617' 93 | print ' 0.196874 0.167343 0.142242 0.120906 0.102770 0.087354 0.074251 0.063113 0.053646 0.045599' 94 | print ' 0.038760 0.032946 0.028004 0.023803 0.020233 0.017198 0.014618 0.012425 0.010562 0.008977' 95 | print ' 0.007631 0.006486 0.005513' 96 | print ' 5 1.000000 0.000000 0.100000 0.000000 0.000000 0.000000 0.000000 0.000000 0.000000 0.000000' 97 | print ' 0.000000 0.000000 0.000000 0.000000 0.000000 0.000000 0.000000 0.000000 0.000000 0.000000' 98 | print ' 0.000000 0.000000 0.000000 0.000000 0.000000 0.000000 0.000000 0.000000 0.000000 0.000000' 99 | print ' 0.000000 0.000000 0.000000' 100 | print ' 6 1.000000 0.000000 0.100000 0.000000 0.000000 0.000000 0.000000 0.000000 0.000000 0.000000' 101 | print ' 0.000000 0.000000 0.000000 0.000000 0.000000 0.000000 0.000000 0.000000 0.000000 0.000000' 102 | print ' 0.000000 0.000000 0.000000 0.000000 0.000000 0.000000 0.000000 0.000000 0.000000 0.000000' 103 | print ' 0.000000 0.000000 0.000000' 104 | print '\n' 105 | print ' <----------------------- FLUXES ----------------------->' 106 | print ' Optical Compu Downward Downward Downward Upward Mean Planck d(Net Flux)' 107 | print ' Depth Layer Direct Diffuse Total Diffuse Net Intensity Source / d(Op Dep)' 108 | print '' 109 | print ' 0.0000 1 7.071E-01 1.192E-07 7.071E-01 8.424E-02 6.229E-01 9.523E-02 0.000E+00 5.983E-01' 110 | print ' 1.0000 4 1.719E-01 3.888E-01 5.607E-01 5.607E-02 5.046E-01 8.305E-02 0.000E+00 1.044E-01' 111 | print '\n' 112 | print ' ********* I N T E N S I T I E S *********' 113 | print '' 114 | print ' Polar Azimuth angles (degrees)' 115 | print ' Optical Angle' 116 | print ' Depth Cosine' 117 | print '' 118 | print ' 0.00 60.00 120.00' 119 | print ' 0.0000 -1.0000 0.000E+00 0.000E+00 0.000E+00' 120 | print ' -0.5000 0.000E+00 0.000E+00 0.000E+00' 121 | print ' 0.5000 4.465E-02 3.413E-02 2.211E-02' 122 | print ' 1.0000 2.149E-02 2.149E-02 2.149E-02' 123 | print '' 124 | print ' 0.00 60.00 120.00' 125 | print ' 1.0000 -1.0000 4.352E-02 4.352E-02 4.352E-02' 126 | print ' -0.5000 6.599E-01 7.163E-02 2.009E-02' 127 | print ' 0.5000 1.785E-02 1.785E-02 1.785E-02' 128 | print ' 1.0000 1.785E-02 1.785E-02 1.785E-02' 129 | --------------------------------------------------------------------------------