| 1 | program kcm1d |
|---|
| 2 | |
|---|
| 3 | use radinc_h, only: NAERKIND |
|---|
| 4 | use radcommon_h, only: L_NSPECTI, L_NSPECTV, sigma |
|---|
| 5 | use watercommon_h, only: mH2O |
|---|
| 6 | use ioipsl_getincom |
|---|
| 7 | |
|---|
| 8 | implicit none |
|---|
| 9 | |
|---|
| 10 | !================================================================== |
|---|
| 11 | ! |
|---|
| 12 | ! Purpose |
|---|
| 13 | ! ------- |
|---|
| 14 | ! Run the universal model radiative transfer once in a 1D column. |
|---|
| 15 | ! Useful for climate evolution studies etc. |
|---|
| 16 | ! |
|---|
| 17 | ! It can be compiled with a command like (e.g. for 25 layers): |
|---|
| 18 | ! "makegcm -p std -d 25 kcm1d" |
|---|
| 19 | ! It requires the files "callphys.def", "gases.def" |
|---|
| 20 | ! "traceur.def", and "run.def" with a line "INCLUDEDEF=callphys.def" |
|---|
| 21 | ! |
|---|
| 22 | ! Authors |
|---|
| 23 | ! ------- |
|---|
| 24 | ! R. Wordsworth |
|---|
| 25 | ! |
|---|
| 26 | !================================================================== |
|---|
| 27 | |
|---|
| 28 | #include "dimensions.h" |
|---|
| 29 | #include "dimphys.h" |
|---|
| 30 | #include "callkeys.h" |
|---|
| 31 | #include "comcstfi.h" |
|---|
| 32 | #include "planete.h" |
|---|
| 33 | #include "comsaison.h" |
|---|
| 34 | #include "control.h" |
|---|
| 35 | #include "advtrac.h" |
|---|
| 36 | |
|---|
| 37 | ! -------------------------------------------------------------- |
|---|
| 38 | ! Declarations |
|---|
| 39 | ! -------------------------------------------------------------- |
|---|
| 40 | |
|---|
| 41 | integer nlayer,nlevel,nq |
|---|
| 42 | integer ilay,ilev,iq,iw,iter |
|---|
| 43 | real play(nlayermx) ! Pressure at the middle of the layers [Pa] |
|---|
| 44 | real zlay(nlayermx) ! Altitude at middle of the layers [km] |
|---|
| 45 | real plev(nlayermx+1) ! Intermediate pressure levels [Pa] |
|---|
| 46 | real temp(nlayermx) ! temperature at the middle of the layers [K] |
|---|
| 47 | real q(nlayermx,nqmx) ! tracer mixing ratio [kg/kg] |
|---|
| 48 | real vmr(nlayermx,nqmx) ! tracer mixing ratio [mol/mol] |
|---|
| 49 | real qsurf(nqmx) ! tracer surface budget [kg/kg] ???? |
|---|
| 50 | real psurf,psurf_n,tsurf |
|---|
| 51 | |
|---|
| 52 | real emis, albedo |
|---|
| 53 | |
|---|
| 54 | real muvar(nlayermx+1) |
|---|
| 55 | |
|---|
| 56 | real dtsw(nlayermx) ! heating rate (K/s) due to SW |
|---|
| 57 | real dtlw(nlayermx) ! heating rate (K/s) due to LW |
|---|
| 58 | real fluxsurf_lw ! incident LW flux to surf (W/m2) |
|---|
| 59 | real fluxtop_lw ! outgoing LW flux to space (W/m2) |
|---|
| 60 | real fluxsurf_sw ! incident SW flux to surf (W/m2) |
|---|
| 61 | real fluxabs_sw ! SW flux absorbed by planet (W/m2) |
|---|
| 62 | real fluxtop_dn ! incident top of atmosphere SW flux (W/m2) |
|---|
| 63 | |
|---|
| 64 | ! not used |
|---|
| 65 | real reffrad(nlayermx,naerkind) |
|---|
| 66 | real nueffrad(nlayermx,naerkind) |
|---|
| 67 | real cloudfrac(nlayermx) |
|---|
| 68 | real totcloudfrac |
|---|
| 69 | real tau_col |
|---|
| 70 | |
|---|
| 71 | real dTstrat |
|---|
| 72 | real aerosol(nlayermx,naerkind) ! aerosol tau (kg/kg) |
|---|
| 73 | real OLR_nu(L_NSPECTI) |
|---|
| 74 | real GSR_nu(L_NSPECTV) |
|---|
| 75 | real Eatmtot |
|---|
| 76 | |
|---|
| 77 | integer ierr |
|---|
| 78 | logical firstcall,lastcall |
|---|
| 79 | |
|---|
| 80 | ! -------------- |
|---|
| 81 | ! Initialisation |
|---|
| 82 | ! -------------- |
|---|
| 83 | |
|---|
| 84 | pi=2.E+0*asin(1.E+0) |
|---|
| 85 | |
|---|
| 86 | reffrad(:,:) = 0.0 |
|---|
| 87 | nueffrad(:,:) = 0.0 |
|---|
| 88 | cloudfrac(:) = 0.0 |
|---|
| 89 | totcloudfrac = 0.0 |
|---|
| 90 | |
|---|
| 91 | ! Load parameters from "run.def" |
|---|
| 92 | ! ------------------------------- |
|---|
| 93 | |
|---|
| 94 | ! check if 'run1d.def' file is around (otherwise reading parameters |
|---|
| 95 | ! from callphys.def via getin() routine won't work.) |
|---|
| 96 | open(90,file='run.def',status='old',form='formatted',& |
|---|
| 97 | iostat=ierr) |
|---|
| 98 | if (ierr.ne.0) then |
|---|
| 99 | write(*,*) 'Cannot find required file "run.def"' |
|---|
| 100 | write(*,*) ' (which should contain some input parameters' |
|---|
| 101 | write(*,*) ' along with the following line:' |
|---|
| 102 | write(*,*) ' INCLUDEDEF=callphys.def' |
|---|
| 103 | write(*,*) ' )' |
|---|
| 104 | write(*,*) ' ... might as well stop here ...' |
|---|
| 105 | stop |
|---|
| 106 | else |
|---|
| 107 | close(90) |
|---|
| 108 | endif |
|---|
| 109 | |
|---|
| 110 | nlayer=nlayermx |
|---|
| 111 | nlevel=nlayer+1 |
|---|
| 112 | |
|---|
| 113 | psurf_n=100000. ! default value for psurf |
|---|
| 114 | print*,'Dry surface pressure (Pa)?' |
|---|
| 115 | call getin("psurf",psurf_n) |
|---|
| 116 | write(*,*) " psurf = ",psurf_n |
|---|
| 117 | |
|---|
| 118 | tsurf=300.0 ! default value for tsurf |
|---|
| 119 | print*,'Surface temperature (K)?' |
|---|
| 120 | call getin("tref",tsurf) |
|---|
| 121 | write(*,*) " tsurf = ",tsurf |
|---|
| 122 | |
|---|
| 123 | g=10.0 ! default value for g |
|---|
| 124 | print*,'Gravity ?' |
|---|
| 125 | call getin("g",g) |
|---|
| 126 | write(*,*) " g = ",g |
|---|
| 127 | |
|---|
| 128 | periastr = 1.0 |
|---|
| 129 | apoastr = 1.0 |
|---|
| 130 | print*,'Periastron (AU)?' |
|---|
| 131 | call getin("periastr",periastr) |
|---|
| 132 | write(*,*) "periastron = ",periastr |
|---|
| 133 | dist_star = periastr |
|---|
| 134 | fract = 0.5 |
|---|
| 135 | print*,'Apoastron (AU)?' |
|---|
| 136 | call getin("apoastr",apoastr) |
|---|
| 137 | write(*,*) "apoastron = ",apoastr |
|---|
| 138 | |
|---|
| 139 | albedo=0.2 ! default value for albedo |
|---|
| 140 | print*,'Albedo of bare ground?' |
|---|
| 141 | call getin("albedo",albedo) |
|---|
| 142 | write(*,*) " albedo = ",albedo |
|---|
| 143 | |
|---|
| 144 | emis=1.0 ! default value for emissivity |
|---|
| 145 | PRINT *,'Emissivity of bare ground ?' |
|---|
| 146 | call getin("emis",emis) |
|---|
| 147 | write(*,*) " emis = ",emis |
|---|
| 148 | |
|---|
| 149 | pceil=100.0 ! Pascals |
|---|
| 150 | PRINT *,'Ceiling pressure (Pa) ?' |
|---|
| 151 | call getin("pceil",pceil) |
|---|
| 152 | write(*,*) " pceil = ", pceil |
|---|
| 153 | |
|---|
| 154 | mugaz=0. |
|---|
| 155 | cpp=0. |
|---|
| 156 | |
|---|
| 157 | call su_gases |
|---|
| 158 | call calc_cpp_mugaz |
|---|
| 159 | |
|---|
| 160 | |
|---|
| 161 | call inifis(1,llm,0,86400.0,1.0,0.0,0.0,1.0,rad,g,r,cpp) |
|---|
| 162 | |
|---|
| 163 | ! Tracer initialisation |
|---|
| 164 | ! --------------------- |
|---|
| 165 | if (tracer) then |
|---|
| 166 | ! load tracer names from file 'traceur.def' |
|---|
| 167 | open(90,file='traceur.def',status='old',form='formatted',& |
|---|
| 168 | iostat=ierr) |
|---|
| 169 | if (ierr.eq.0) then |
|---|
| 170 | write(*,*) "kcm1d: Reading file traceur.def" |
|---|
| 171 | ! read number of tracers: |
|---|
| 172 | read(90,*,iostat=ierr) nq |
|---|
| 173 | if (ierr.ne.0) then |
|---|
| 174 | write(*,*) "kcm1d: error reading number of tracers" |
|---|
| 175 | write(*,*) " (first line of traceur.def) " |
|---|
| 176 | stop |
|---|
| 177 | else |
|---|
| 178 | ! check that the number of tracers is indeed nqmx |
|---|
| 179 | if (nq.ne.nqmx) then |
|---|
| 180 | write(*,*) "kcm1d: error, wrong number of tracers:" |
|---|
| 181 | write(*,*) "nq=",nq," whereas nqmx=",nqmx |
|---|
| 182 | stop |
|---|
| 183 | endif |
|---|
| 184 | endif |
|---|
| 185 | |
|---|
| 186 | do iq=1,nq |
|---|
| 187 | ! minimal version, just read in the tracer names, 1 per line |
|---|
| 188 | read(90,*,iostat=ierr) tnom(iq) |
|---|
| 189 | if (ierr.ne.0) then |
|---|
| 190 | write(*,*) 'kcm1d: error reading tracer names...' |
|---|
| 191 | stop |
|---|
| 192 | endif |
|---|
| 193 | enddo !of do iq=1,nq |
|---|
| 194 | endif |
|---|
| 195 | !endif |
|---|
| 196 | |
|---|
| 197 | call initracer() |
|---|
| 198 | |
|---|
| 199 | endif |
|---|
| 200 | |
|---|
| 201 | |
|---|
| 202 | do iq=1,nqmx |
|---|
| 203 | do ilay=1,nlayer |
|---|
| 204 | q(ilay,iq) = 0. |
|---|
| 205 | enddo |
|---|
| 206 | enddo |
|---|
| 207 | |
|---|
| 208 | do iq=1,nqmx |
|---|
| 209 | qsurf(iq) = 0. |
|---|
| 210 | enddo |
|---|
| 211 | |
|---|
| 212 | firstcall = .true. |
|---|
| 213 | lastcall = .false. |
|---|
| 214 | |
|---|
| 215 | iter = 1 |
|---|
| 216 | Tstrat = 60.0 |
|---|
| 217 | dTstrat = 1000.0 |
|---|
| 218 | |
|---|
| 219 | ! --------- |
|---|
| 220 | ! Run model |
|---|
| 221 | ! --------- |
|---|
| 222 | do |
|---|
| 223 | psurf = psurf_n |
|---|
| 224 | |
|---|
| 225 | ! Create vertical profiles |
|---|
| 226 | call kcmprof_fn(psurf,qsurf(1),tsurf, & |
|---|
| 227 | tstrat,play,plev,zlay,temp,q(:,1),muvar(1)) |
|---|
| 228 | |
|---|
| 229 | ! Run radiative transfer |
|---|
| 230 | call callcorrk(ngridmx,nlayer,q,nqmx,qsurf, & |
|---|
| 231 | albedo,emis,mu0,plev,play,temp, & |
|---|
| 232 | tsurf,fract,dist_star,aerosol,cpp,muvar, & |
|---|
| 233 | dtlw,dtsw,fluxsurf_lw,fluxsurf_sw,fluxtop_lw, & |
|---|
| 234 | fluxabs_sw,fluxtop_dn,reffrad,tau_col, & |
|---|
| 235 | cloudfrac,totcloudfrac,.false.,firstcall,lastcall) |
|---|
| 236 | |
|---|
| 237 | ! Iterate stratospheric temperature |
|---|
| 238 | print*,'Tstrat = ',Tstrat |
|---|
| 239 | dTstrat = Tstrat |
|---|
| 240 | !Tstrat = Tsurf*(0.2786*(psurf/100000.)**(-1.123))**0.25 |
|---|
| 241 | ! skin temperature (gray approx.) using analytic pure H2 expression |
|---|
| 242 | !Tstrat = (fluxabs_sw/(2*sigma))**0.25 ! skin temperature (gray approx.) |
|---|
| 243 | Tstrat = (fluxtop_lw/(2*sigma))**0.25 ! skin temperature (gray approx.) |
|---|
| 244 | dTstrat = dTstrat-Tstrat |
|---|
| 245 | |
|---|
| 246 | if(abs(dTstrat).lt.1.0)then |
|---|
| 247 | print*,'dTstrat = ',dTstrat |
|---|
| 248 | exit |
|---|
| 249 | endif |
|---|
| 250 | |
|---|
| 251 | iter=iter+1 |
|---|
| 252 | if(iter.eq.100)then |
|---|
| 253 | print*,'Stratosphere failed to converge after' |
|---|
| 254 | print*,'100 iteration, aborting run.' |
|---|
| 255 | call abort |
|---|
| 256 | endif |
|---|
| 257 | |
|---|
| 258 | end do |
|---|
| 259 | |
|---|
| 260 | ! Calculate total atmospheric energy |
|---|
| 261 | Eatmtot=0.0 |
|---|
| 262 | ! call calcenergy_kcm(tsurf,temp,play,plev,qsurf,& |
|---|
| 263 | ! q(:,1),muvar,Eatmtot) |
|---|
| 264 | |
|---|
| 265 | ! ------------------------ |
|---|
| 266 | ! Save data to ascii files |
|---|
| 267 | ! ------------------------ |
|---|
| 268 | |
|---|
| 269 | print*,'Saving profiles...' |
|---|
| 270 | open(115,file='profpres.out',form='formatted') |
|---|
| 271 | open(116,file='proftemp.out',form='formatted') |
|---|
| 272 | open(117,file='profztab.out',form='formatted') |
|---|
| 273 | open(118,file='profqvar.out',form='formatted') |
|---|
| 274 | open(119,file='profvvar.out',form='formatted') |
|---|
| 275 | |
|---|
| 276 | write(115,*) psurf |
|---|
| 277 | write(116,*) tsurf |
|---|
| 278 | write(117,*) 0.0 |
|---|
| 279 | write(118,*) qsurf(1) |
|---|
| 280 | write(119,*) qsurf(1)*(muvar(1)/mH2O) |
|---|
| 281 | do ilay=1,nlayer |
|---|
| 282 | vmr(ilay,1) = q(ilay,1)*(muvar(ilay+1)/mH2O) |
|---|
| 283 | write(115,*) play(ilay) |
|---|
| 284 | write(116,*) temp(ilay) |
|---|
| 285 | write(117,*) zlay(ilay) |
|---|
| 286 | write(118,*) q(ilay,1) |
|---|
| 287 | write(119,*) vmr(ilay,1) |
|---|
| 288 | enddo |
|---|
| 289 | close(115) |
|---|
| 290 | close(116) |
|---|
| 291 | close(117) |
|---|
| 292 | close(118) |
|---|
| 293 | close(119) |
|---|
| 294 | |
|---|
| 295 | print*,'Saving scalars...' |
|---|
| 296 | open(116,file='surf_vals.out') |
|---|
| 297 | write(116,*) tsurf,psurf,fluxtop_dn, & |
|---|
| 298 | fluxabs_sw,fluxtop_lw |
|---|
| 299 | close(116) |
|---|
| 300 | open(111,file='ene_vals.out') |
|---|
| 301 | write(111,*) tsurf,psurf,Eatmtot,Tstrat |
|---|
| 302 | close(111) |
|---|
| 303 | |
|---|
| 304 | print*,'Saving spectra...' |
|---|
| 305 | open(117,file='OLRnu.out') |
|---|
| 306 | do iw=1,L_NSPECTI |
|---|
| 307 | write(117,*) OLR_nu(iw) |
|---|
| 308 | enddo |
|---|
| 309 | close(117) |
|---|
| 310 | |
|---|
| 311 | open(127,file='GSRnu.out') |
|---|
| 312 | do iw=1,L_NSPECTV |
|---|
| 313 | write(127,*) GSR_nu(iw) |
|---|
| 314 | enddo |
|---|
| 315 | close(127) |
|---|
| 316 | |
|---|
| 317 | end program kcm1d |
|---|
