Index: trunk/LMDZ.MARS/libf/phymars/LUdec.F =================================================================== --- trunk/LMDZ.MARS/libf/phymars/LUdec.F (revision 496) +++ (revision ) @@ -1,52 +1,0 @@ -ccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -c -c Solution of linear equation without inverting matrix -c using LU decomposition: -c AA * xx = bb AA, bb: known -c xx: to be found -c AA and bb are not modified in this subroutine -c -c MALV , Sep 2007 -ccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - - subroutine LUdec(xx,aa,bb,m,n) - - implicit none - -! Arguments - integer m, n - real*8 aa(m,m), bb(m), xx(m) - - -! Local variables - real*8 a(n,n), b(n), x(n), d - integer i, j, indx(n) - - -! Subrutinas utilizadas -! ludcmp_dp, lubksb_dp - -!!!!!!!!!!!!!!! Comienza el programa !!!!!!!!!!!!!! - - do i=1,n - b(i) = bb(i+1) - do j=1,n - a(i,j) = aa(i+1,j+1) - enddo - enddo - - ! Descomposicion de auxm1 - call ludcmp_dp ( a, n, n, indx, d) - - ! Sustituciones foward y backwards para hallar la solucion - do i=1,n - x(i) = b(i) - enddo - call lubksb_dp( a, n, n, indx, x ) - - do i=1,n - xx(i+1) = x(i) - enddo - - return - end Index: trunk/LMDZ.MARS/libf/phymars/NIR_leedat.F =================================================================== --- trunk/LMDZ.MARS/libf/phymars/NIR_leedat.F (revision 496) +++ (revision ) @@ -1,38 +1,0 @@ -c*********************************************************************** - subroutine NIR_leedat - -c reads parameters for NIR NLTE calculation - -c nov 2011 fgg+malv first version -c*********************************************************************** - - implicit none - - include 'datafile.h' - include 'NIRdata.h' - - -c local variables - - integer ind - - -c*********************************************************************** - - open(43,file=trim(datafile)//'/NIRcorrection_feb2011.dat', - $ status='old') - do ind=1,9 - read(43,*) - enddo - - do ind=1,npres - read(43,*)pres1d(ind),corgcm(ind),oco21d(ind),p1999(ind), - $ alfa(ind) - !Tabulated pression to Pa - pres1d(ind)=pres1d(ind)*100. - enddo - close(43) - - return - - end Index: trunk/LMDZ.MARS/libf/phymars/NIRdata.h =================================================================== --- trunk/LMDZ.MARS/libf/phymars/NIRdata.h (revision 496) +++ (revision ) @@ -1,8 +1,0 @@ - - integer npres ! Number of pressures in NIR correction - parameter (npres=42) ! table - - common /NIRdata/ pres1d,corgcm,oco21d,alfa,p1999 - real pres1d(npres) - real corgcm(npres) - real oco21d(npres),alfa(npres),p1999(npres) Index: trunk/LMDZ.MARS/libf/phymars/NLTE_leedat.F =================================================================== --- trunk/LMDZ.MARS/libf/phymars/NLTE_leedat.F (revision 496) +++ (revision ) @@ -1,206 +1,0 @@ -c*********************************************************************** - subroutine NLTE_leedat - -c reads planetary and molecular parameters - -c jan 98 malv first version -c jul 2011 malv+fgg adapted to LMD-MGCM -c*********************************************************************** - - implicit none - - include 'nltedefs.h' - include 'nlte_data.h' - include 'datafile.h' - include 'nlte_curtis.h' - - -c local variables - integer i,j, k,lun1, lun2 - integer ib - integer isot - character isotcode*2 - character ibcode1*1 - -c formats -132 format (i2) -101 format(i1) -c*********************************************************************** - - lun1 = 1 - lun2 = 2 - - do k=1,nisot -! encode (2,132,isotcode) indexisot(k) - write (isotcode,132) indexisot(k) - open (lun1, - @ file=trim(datafile)//'/NLTEDAT/enelow'//isotcode//'.dat', - @ status='old') - open (lun2, - @ file=trim(datafile)//'/NLTEDAT/deltanu'//isotcode//'.dat', - @ status='old') - read (lun1,*) - read (lun2,*) - read (lun1,*) (elow(k,i), i=1,nb) - read (lun2,*) (deltanu(k,i), i=1,nb) - close (lun1) - close (lun2) - end do - - -c Call to rhist - - hfile1='hid' -! if (ib.eq.13 .or. ib.eq.14 ) hfile1 = dirspec//'his' - if (ib.eq.13 .or. ib.eq.14 ) hfile1 = 'his' - - ib=1 - do isot=1,4 -c Cases 1,2,3,4 - if (isot.eq.1) hisfile = hfile1//'26-1.dat' - if (isot.eq.2) hisfile = hfile1//'28-1.dat' - if (isot.eq.3) hisfile = hfile1//'36-1.dat' - if (isot.eq.4) hisfile = hfile1//'27-1.dat' - call rhist(1.0) - if (isot.eq.1) then !Case 1 - mm_c1=mm - nbox_c1=nbox - tmin_c1=tmin - tmax_c1=tmax - do i=1,nbox_max - no_c1(i)=no(i) - dist_c1(i)=dist(i) - do j=1,nhist - sk1_c1(j,i)=sk1(j,i) - xls1_c1(j,i)=xls1(j,i) - xln1_c1(j,i)=xln1(j,i) - xld1_c1(j,i)=xld1(j,i) - enddo - enddo - do j=1,nhist - thist_c1(j)=thist(j) - enddo - else if(isot.eq.2) then !Case 2 - mm_c2=mm - nbox_c2=nbox - tmin_c2=tmin - tmax_c2=tmax - do i=1,nbox_max - no_c2(i)=no(i) - dist_c2(i)=dist(i) - do j=1,nhist - sk1_c2(j,i)=sk1(j,i) - xls1_c2(j,i)=xls1(j,i) - xln1_c2(j,i)=xln1(j,i) - xld1_c2(j,i)=xld1(j,i) - enddo - enddo - do j=1,nhist - thist_c2(j)=thist(j) - enddo - else if (isot.eq.3) then ! Case 3 - mm_c3=mm - nbox_c3=nbox - tmin_c3=tmin - tmax_c3=tmax - do i=1,nbox_max - no_c3(i)=no(i) - dist_c3(i)=dist(i) - do j=1,nhist - sk1_c3(j,i)=sk1(j,i) - xls1_c3(j,i)=xls1(j,i) - xln1_c3(j,i)=xln1(j,i) - xld1_c3(j,i)=xld1(j,i) - enddo - enddo - do j=1,nhist - thist_c3(j)=thist(j) - enddo - else if (isot.eq.4) then ! Case 4 - mm_c4=mm - nbox_c4=nbox - tmin_c4=tmin - tmax_c4=tmax - do i=1,nbox_max - no_c4(i)=no(i) - dist_c4(i)=dist(i) - do j=1,nhist - sk1_c4(j,i)=sk1(j,i) - xls1_c4(j,i)=xls1(j,i) - xln1_c4(j,i)=xln1(j,i) - xld1_c4(j,i)=xld1(j,i) - enddo - enddo - do j=1,nhist - thist_c4(j)=thist(j) - enddo - endif - enddo - do ib=2,4 - isot=1 - write (ibcode1,101) ib - hisfile = hfile1//'26-'//ibcode1//'.dat' - call rhist (1.0) - if (ib.eq.2) then !Case 5 - mm_c5=mm - nbox_c5=nbox - tmin_c5=tmin - tmax_c5=tmax - do i=1,nbox_max - no_c5(i)=no(i) - dist_c5(i)=dist(i) - do j=1,nhist - sk1_c5(j,i)=sk1(j,i) - xls1_c5(j,i)=xls1(j,i) - xln1_c5(j,i)=xln1(j,i) - xld1_c5(j,i)=xld1(j,i) - enddo - enddo - do j=1,nhist - thist_c5(j)=thist(j) - enddo - else if (ib.eq.3) then !Case 6 - mm_c6=mm - nbox_c6=nbox - tmin_c6=tmin - tmax_c6=tmax - do i=1,nbox_max - no_c6(i)=no(i) - dist_c6(i)=dist(i) - do j=1,nhist - sk1_c6(j,i)=sk1(j,i) - xls1_c6(j,i)=xls1(j,i) - xln1_c6(j,i)=xln1(j,i) - xld1_c6(j,i)=xld1(j,i) - enddo - enddo - do j=1,nhist - thist_c6(j)=thist(j) - enddo - else if (ib.eq.4) then !Case 7 - mm_c7=mm - nbox_c7=nbox - tmin_c7=tmin - tmax_c7=tmax - do i=1,nbox_max - no_c7(i)=no(i) - dist_c7(i)=dist(i) - do j=1,nhist - sk1_c7(j,i)=sk1(j,i) - xls1_c7(j,i)=xls1(j,i) - xln1_c7(j,i)=xln1(j,i) - xld1_c7(j,i)=xld1(j,i) - enddo - enddo - do j=1,nhist - thist_c7(j)=thist(j) - enddo - endif - enddo - -c end - return - - end - - Index: trunk/LMDZ.MARS/libf/phymars/NLTEdlvr09_CZALU.F =================================================================== --- trunk/LMDZ.MARS/libf/phymars/NLTEdlvr09_CZALU.F (revision 496) +++ (revision ) @@ -1,842 +1,0 @@ -c*********************************************************************** - - subroutine NLTEdlvr09_CZALU(ig) - -c jul 2011 malv+fgg -c*********************************************************************** - - implicit none - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! common variables and constants - - include 'nltedefs.h' - include 'nlte_atm.h' - include 'nlte_data.h' - include 'nlte_results.h' - include 'tcr_15um.h' - include 'nlte_matrix.h' - include 'nlte_rates.h' - include 'nlte_curtis.h' - -c arguments - - integer ig !ADDED FOR TRACEBACK - -c local variables - -! matrixes and vectors - - real*8 e110(nl), e210(nl), e310(nl), e410(nl) - real*8 e121(nl), e112(nl) - - real*8 f1(nl,nl) - - real*8 cax1(nl,nl), cax2(nl,nl), cax3(nl,nl) - real*8 v1(nl), v2(nl), v3(nl) - - real*8 alf11(nl,nl), alf12(nl,nl) - real*8 alf21(nl,nl), alf31(nl,nl), alf41(nl,nl) - real*8 a11(nl), a1112(nl,nl) - real*8 a1121(nl,nl), a1131(nl,nl), a1141(nl,nl) - real*8 a21(nl), a2131(nl,nl), a2141(nl,nl) - real*8 a2111(nl,nl), a2112(nl,nl) - real*8 a31(nl), a3121(nl,nl), a3141(nl,nl) - real*8 a3111(nl,nl), a3112(nl,nl) - real*8 a41(nl), a4121(nl,nl), a4131(nl,nl) - real*8 a4111(nl,nl), a4112(nl,nl) - real*8 a12(nl), a1211(nl,nl) - real*8 a1221(nl,nl), a1231(nl,nl), a1241(nl,nl) - - real*8 aalf11(nl,nl),aalf21(nl,nl),aalf31(nl,nl),aalf41(nl,nl) - real*8 aa11(nl), aa1121(nl,nl), aa1131(nl,nl), aa1141(nl,nl) - real*8 aa21(nl), aa2111(nl,nl), aa2131(nl,nl), aa2141(nl,nl) - real*8 aa31(nl), aa3111(nl,nl), aa3121(nl,nl), aa3141(nl,nl) - real*8 aa41(nl), aa4111(nl,nl), aa4121(nl,nl), aa4131(nl,nl) - real*8 aa12(nl) - real*8 aa1211(nl,nl), aa1221(nl,nl), aa1231(nl,nl), aa1241(nl,nl) - real*8 aa1112(nl,nl), aa2112(nl,nl), aa3112(nl,nl), aa4112(nl,nl) - - real*8 aaalf11(nl,nl),aaalf21(nl,nl),aaalf31(nl,nl),aaalf41(nl,nl) - real*8 aaa11(nl),aaa1121(nl,nl),aaa1131(nl,nl),aaa1141(nl,nl) - real*8 aaa21(nl),aaa2111(nl,nl),aaa2131(nl,nl),aaa2141(nl,nl) - real*8 aaa31(nl),aaa3111(nl,nl),aaa3121(nl,nl),aaa3141(nl,nl) - real*8 aaa41(nl),aaa4111(nl,nl),aaa4121(nl,nl),aaa4131(nl,nl) - - real*8 aaaalf11(nl,nl),aaaalf41(nl,nl) - real*8 aaaa11(nl),aaaa1141(nl,nl) - real*8 aaaa41(nl),aaaa4111(nl,nl) - - - -! populations - real*8 n10(nl), n11(nl) - real*8 n20(nl), n21(nl) - real*8 n30(nl), n31(nl) - real*8 n40(nl), n41(nl) - - -! productions and loses - real*8 d19a1,d19b1,d19c1 - real*8 d19ap1,d19bp1,d19cp1 - real*8 d19a2,d19b2,d19c2 - real*8 d19ap2,d19bp2,d19cp2 - real*8 d19a3,d19b3,d19c3 - real*8 d19ap3,d19bp3,d19cp3 - real*8 d19a4,d19b4,d19c4 - real*8 d19ap4,d19bp4,d19cp4 - - real*8 l11, l12, l21, l31, l41 - real*8 p11, p12, p21, p31, p41 - real*8 p1112, p1211, p1221, p1231, p1241 - real*8 p1121, p1131, p1141 - real*8 p2111, p2112, p2131, p2141 - real*8 p3111, p3112, p3121, p3141 - real*8 p4111, p4112, p4121, p4131 - - - real*8 ps11, ps21, ps31, ps41, ps12 - - real*8 pl11, pl12, pl21, pl31, pl41 - -c local constants and indexes - - integer ii ! decides if output of tv,hr - integer icurt ! decides if read/comp c.matrix - - real*8 co2t - real*8 ftest - - real*8 a11_einst(nl), a12_einst(nl) - real*8 a21_einst(nl), a31_einst(nl), a41_einst(nl) - real tsurf - - real*8 nu11, nu12, nu121, nu21, nu31, nu41 - - integer i, j, ik, isot , icurtishb - integer i_by15sh, i_col020, i_col010636 - - -c external functions and subroutines - - external planckdp - real*8 planckdp - -! subroutines called: -! mz4sub, dmzout, readc_mz4, mztf - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! start program - - - ii = 4 - icurt = 1 - - call zero4v( aa11, aa21, aa31, aa41, nl) - call zero4m( aa1121, aa1131, aa1141, aalf11, nl) - call zero4m( aa2111, aa2131, aa2141, aalf21, nl) - call zero4m( aa3111, aa3121, aa3141, aalf31, nl) - call zero4m( aa4111, aa4121, aa4131, aalf41, nl) - call zero4m( aa1112, aa2112, aa3112, aa4112, nl) - call zero4m( aa1211, aa1221, aa1231, aa1241, nl) - call zero3v( aaa41, aaa31, aaa11, nl ) - call zero3m( aaa4111, aaa4131, aaalf41, nl) - call zero3m( aaa3111, aaa3141, aaalf31, nl) - call zero3m( aaa1131, aaa1141, aaalf11, nl) - call zero2v( aaaa11, aaaa41, nl ) - call zero2m( aaaa1141, aaaalf11, nl) - call zero2m( aaaa4111, aaaalf41, nl) - - !write (*,*) ' --- c z a simple --- input_cza : ', input_cza - - - call zero3v (vt11,vt12,vt13,nl) - call zero3v (vt21,vt22,vt23,nl) - call zero3v (vt31,vt32,vt33,nl) - call zero3v (vt41,vt42,vt43,nl) - - call zero3v (hr110,hr121,hr132,nl) - call zero3v (hr210,hr221,hr232,nl) - call zero3v (hr310,hr321,hr332,nl) - call zero3v (hr410,hr421,hr432,nl) - call zero3v (sl110,sl121,sl132,nl) - call zero3v (sl210,sl221,sl232,nl) - call zero3v (sl310,sl321,sl332,nl) - call zero3v (sl410,sl421,sl432,nl) - - call zero4v (el11,el21,el31,el41,nl) - call zero4v (e110,e210,e310,e410,nl) - call zero3v (el12,e121,e112,nl) - - call zero3m (cax1,cax2,cax3,nl) - call zerom (f1,nl) - call zero3v (v1,v2,v3,nl) - - call zero4m (alf11,alf21,alf31,alf41,nl) - call zerom (alf12,nl) - call zero2v (a11,a12,nl) - call zero3v (a21,a31,a41,nl) - - call zero3m (a1121,a1131,a1141,nl) - call zerom (a1112,nl) - - call zero3m (a1221,a1231,a1241,nl) - call zerom (a1211,nl) - - call zero2m (a2111,a2112,nl) - call zero2m (a2131,a2141,nl) - call zero2m (a3111,a3112,nl) - call zero2m (a3121,a3141,nl) - call zero2m (a4111,a4112,nl) - call zero2m (a4121,a4131,nl) - - - call zero4v (n11,n21,n31,n41,nl) - - nu11 = nu(1,1) - nu12 = nu(1,2) - nu121 = nu12-nu11 - - nu21 = nu(2,1) - - nu31 = nu(3,1) - - nu41 = nu(4,1) - - ftest = 1.d0 - i_by15sh = 1 - i_col020 = 1 - - i_col010636 = 1 - - -101 format(a1) -180 format(a80) - - -c establishing molecular populations needed as input - do i=1,nl - n10(i) = dble( co2(i) * imr(1) ) - n20(i) = dble( co2(i) * imr(2) ) - n30(i) = dble( co2(i) * imr(3) ) - n40(i) = dble( co2(i) * imr(4) ) - if ( input_cza.ge.1 ) then - n11(i) = n10(i) *2.d0 *exp( dble(-ee*nu(1,1))/v626t1(i) ) - n21(i) = n20(i) *2.d0 *exp( dble(-ee*nu(2,1))/v628t1(i) ) - n31(i) = n30(i) *2.d0* exp( dble(-ee*nu(3,1))/v636t1(i) ) - n41(i) = n40(i) *2.d0* exp( dble(-ee*nu(4,1))/v627t1(i) ) - end if - enddo - -cc -cc curtis matrix calculation -cc - if ( input_cza.ge.1 ) then - - if (itt_cza.eq.15 ) then - - call cm15um_hb_simple ( ig,icurt ) - - elseif (itt_cza.eq.13) then - - call mztvc_626fh(ig) - - endif - - endif - - - - do 4,i=nl,1,-1 !---------------------------------------------- - - co2t = dble ( co2(i) *(imr(1)+imr(3)+imr(2)+imr(4)) ) - - call getk ( t(i) ) - - ps11 = 0.d0 - ps21 = 0.d0 - ps31 = 0.d0 - ps41 = 0.d0 - ps12 = 0.d0 - - ! V-T productions and losses V-T - - isot = 1 - d19b1 = dble(k19ba(isot)*co2t+k19bb(isot)*n2(i)) - @ + dble(k19bc(isot)*co(i)) - d19c1 = dble(k19ca(isot)*co2t+k19cb(isot)*n2(i)) - @ + dble(k19cc(isot)*co(i)) - d19bp1 = dble( k19bap(isot)*co2t + k19bbp(isot)*n2(i) ) - @ + dble( k19bcp(isot)*co(i) ) - d19cp1 = dble( k19cap(isot)*co2t + k19cbp(isot)*n2(i) ) - @ + dble( k19ccp(isot)*co(i) ) - isot = 2 - d19c2 =dble(k19ca(isot)*co2t+k19cb(isot)*n2(i)) - @ + dble(k19cc(isot)*co(i)) - d19cp2 =dble( k19cap(isot)*co2t + k19cbp(isot)*n2(i) ) - @ + dble( k19ccp(isot)*co(i) ) - isot = 3 - d19c3 =dble(k19ca(isot)*co2t+k19cb(isot)*n2(i)) - @ + dble(k19cc(isot)*co(i)) - d19cp3 =dble( k19cap(isot)*co2t + k19cbp(isot)*n2(i) ) - @ + dble( k19ccp(isot)*co(i) ) - isot = 4 - d19c4 =dble(k19ca(isot)*co2t+k19cb(isot)*n2(i)) - @ + dble(k19cc(isot)*co(i)) - d19cp4 =dble( k19cap(isot)*co2t + k19cbp(isot)*n2(i) ) - @ + dble(k19ccp(isot)*co(i) ) - ! - l11 = d19c1 + k20c(1)*dble(o3p(i)) - p11 = ( d19cp1 + k20cp(1)*dble(o3p(i)) ) * n10(i) - l21 = d19c2 + k20c(2)*dble(o3p(i)) - p21 = ( d19cp2 + k20cp(2)*dble(o3p(i)) ) *n20(i) - l31 = d19c3 + k20c(3)*dble(o3p(i)) - p31 = ( d19cp3 + k20cp(3)*dble(o3p(i)) ) *n30(i) - l41 = d19c4 + k20c(4)*dble(o3p(i)) - p41 = ( d19cp4 + k20cp(4)*dble(o3p(i)) ) *n40(i) - - ! Addition of V-V - - l11 = l11 + k21cp(2)*n20(i) + k21cp(3)*n30(i) + k21cp(4)*n40(i) - p1121 = k21c(2) * n10(i) - p1131 = k21c(3) * n10(i) - p1141 = k21c(4) * n10(i) - ! - l21 = l21 + k21c(2)*n10(i) + k23k21c*n30(i) + k24k21c*n40(i) - p2111 = k21cp(2) * n20(i) - p2131 = k23k21cp * n20(i) - p2141 = k24k21cp * n20(i) - ! - l31 = l31 + k21c(3)*n10(i) + k23k21cp*n20(i) + k34k21c*n40(i) - p3111 = k21cp(3)* n30(i) - p3121 = k23k21c * n30(i) - p3141 = k34k21cp* n30(i) - ! - l41 = l41 + k21c(4)*n10(i) + k24k21cp*n20(i) + k34k21cp*n30(i) - p4111 = k21cp(4)* n40(i) - p4121 = k24k21c * n40(i) - p4131 = k34k21c * n40(i) - - - if ( input_cza.ge.1 ) then - - l12 = d19b1 - @ + k20b(1)*dble(o3p(i)) - @ + k21b(1)*n10(i) - @ + k33c*( n20(i) + n30(i) + n40(i) ) - p12 = k21bp(1)*n11(i) * n11(i) - p1211 = d19bp1 + k20bp(1)*dble(o3p(i)) - p1221 = k33cp(2)*n11(i) - p1231 = k33cp(3)*n11(i) - p1241 = k33cp(4)*n11(i) - - l11 = l11 + d19bp1 - @ + k20bp(1)*dble(o3p(i)) - @ + 2.d0 * k21bp(1) * n11(i) - @ + k33cp(2)*n21(i) + k33cp(3)*n31(i) + k33cp(4)*n41(i) - p1112 = d19b1 - @ + k20b(1)*dble(o3p(i)) - @ + 2.d0*k21b(1)*n10(i) - @ + k33c*( n20(i) + n30(i) + n40(i) ) - - l21 = l21 + k33cp(2)*n11(i) - p2112 = k33c*n20(i) - - l31 = l31 + k33cp(3)*n11(i) - p3112 = k33c*n30(i) - - l41 = l41 + k33cp(4)*n11(i) - p4112 = k33c*n40(i) - - end if - - - ! Changes in local losses for ITT=13,15 cases - - a21_einst(i) = 1.3452d00 * 1.8 / 4.0 * taustar21(i) - a31_einst(i) = 1.1878d00 * 1.8 / 4.0 * taustar31(i) - a41_einst(i) = 1.2455d00 * 1.8 / 4.0 * taustar41(i) - - l21 = l21 + a21_einst(i) - l31 = l31 + a31_einst(i) - l41 = l41 + a41_einst(i) - - if (input_cza.ge.1 .and. itt_cza.eq.13) then - a12_einst(i) = 4.35d00 / 3.0d0 * 1.8 / 4.0 * taustar12(i) - l12=l12+a12_einst(i) - endif - - if (itt_cza.eq.24) then - a11_einst(i) = a11_einst(i) * 1.8 / 4.0 * taustar11(i) - l11 = l11 + a11_einst(i) - endif - - - ! vectors and matrices for the formulation - - a11(i) = dble(gamma*nu11**3.) * 1.d0/2.d0 * (p11+ps11) / - @ (n10(i)*l11) - a1121(i,i) = dble((nu11/nu21))**3.d0 * n20(i)/n10(i) * p1121/l11 - a1131(i,i) = dble((nu11/nu31))**3.d0 * n30(i)/n10(i) * p1131/l11 - a1141(i,i) = dble((nu11/nu41))**3.d0 * n40(i)/n10(i) * p1141/l11 - e110(i) = 2.d0* dble(vlight*nu11**2.) * 1.d0/2.d0 / - @ ( n10(i) * l11 ) - - a21(i) = dble( gamma*nu21**3.) * 1.d0/2.d0 * - @ (p21+ps21)/(n20(i)*l21) - a2111(i,i) = dble((nu21/nu11))**3.d0 * n10(i)/n20(i) * p2111/l21 - a2131(i,i) = dble((nu21/nu31))**3.d0 * n30(i)/n20(i) * p2131/l21 - a2141(i,i) = dble((nu21/nu41))**3.d0 * n40(i)/n20(i) * p2141/l21 - e210(i) = 2.d0*dble(vlight*nu21**2.) * 1.d0/2.d0 / - @ ( n20(i) * l21 ) - - a31(i) = dble(gamma*nu31**3.) * 1.d0/2.d0 * (p31+ps31) / - @ (n30(i)*l31) - a3111(i,i) = dble((nu31/nu11))**3.d0 * n10(i)/n30(i) * p3111/l31 - a3121(i,i) = dble((nu31/nu21))**3.d0 * n20(i)/n30(i) * p3121/l31 - a3141(i,i) = dble((nu31/nu41))**3.d0 * n40(i)/n30(i) * p3141/l31 - e310(i) = 2.d0*dble(vlight*nu31**2.) * 1.d0/2.d0 / - @ ( n30(i) * l31 ) - - a41(i) = dble(gamma*nu41**3.) * 1.d0/2.d0 * (p41+ps41) / - @ (n40(i)*l41) - a4111(i,i) = dble((nu41/nu11))**3.d0 * n10(i)/n40(i) * p4111/l41 - a4121(i,i) = dble((nu41/nu21))**3.d0 * n20(i)/n40(i) * p4121/l41 - a4131(i,i) = dble((nu41/nu31))**3.d0 * n30(i)/n40(i) * p4131/l41 - e410(i) = 2.d0*dble(vlight*nu41**2.) * 1.d0/2.d0 / - @ ( n40(i) * l41 ) - - if (input_cza.ge.1) then - - a1112(i,i) = dble((nu11/nu121))**3.d0 * n11(i)/n10(i) * - @ p1112/l11 - a2112(i,i) = dble((nu21/nu121))**3.d0 * n11(i)/n20(i) * - @ p2112/l21 - a3112(i,i) = dble((nu31/nu121))**3.d0 * n11(i)/n30(i) * - @ p3112/l31 - a4112(i,i) = dble((nu41/nu121))**3.d0 * n11(i)/n40(i) * - @ p4112/l41 - e112(i) = -2.d0*dble(vlight*nu11**3.)/nu121 /2.d0 / - @ ( n10(i)*l11 ) - a12(i) = dble( gamma*nu121**3.) *2.d0/4.d0* (p12+ps12)/ - @ (n11(i)*l12) - a1211(i,i) = dble((nu121/nu11))**3.d0 * n10(i)/n11(i) * - @ p1211/l12 - a1221(i,i) = dble((nu121/nu21))**3.d0 * n20(i)/n11(i) * - @ p1221/l12 - a1231(i,i) = dble((nu121/nu31))**3.d0 * n30(i)/n11(i) * - @ p1231/l12 - a1241(i,i) = dble((nu121/nu41))**3.d0 * n40(i)/n11(i) * - @ p1241/l12 - e121(i) = 2.d0*dble(vlight*nu121**2.) *2.d0/4.d0 / - @ ( n11(i) * l12 ) - - end if - - -4 continue !------------------------------------------------------- - - - ! Change C.M. - - do i=1,nl - do j=1,nl - c210(i,j) = 0.0d0 - c310(i,j) = 0.0d0 - c410(i,j) = 0.0d0 - end do - end do - if ( itt_cza.eq.13 ) then - do i=1,nl - do j=1,nl - c121(i,j) = 0.0d0 - end do - end do - endif - !Añadido para hacer diagonal C121 -! if ( itt_cza.eq.15 ) then -! do i=1,nl -! do j=1,nl -! if(abs(i-j).eq.1.or.abs(i-j).eq.2) c121(i,j) = 0.0d0 -! end do -! end do -! endif - if ( itt_cza.eq.24 ) then - do i=1,nl - do j=1,nl - c110(i,j) = 0.0d0 - end do - end do - endif - - ! Lower Boundary - tsurf = t(1) + tsurf_excess - do i=1,nl - sl110(i) = sl110(i) + vc110(i) * planckdp( tsurf, nu11 ) - sl210(i) = sl210(i) + vc210(i) * planckdp( tsurf, nu21 ) - sl310(i) = sl310(i) + vc310(i) * planckdp( tsurf, nu31 ) - sl410(i) = sl410(i) + vc410(i) * planckdp( tsurf, nu41 ) - end do - if (input_cza.ge.1) then - do i=1,nl - sl121(i) = sl121(i) + vc121(i) * planckdp( tsurf, nu121 ) - end do - endif - - - !!!!!!!!!!!! Solucion del sistema - - !! Paso 0 : Calculo de los alphas alf11, alf21, alf31, alf41, alf12 - - call unit ( cax2, nl ) - - call diago ( cax1, e110, nl ) - call mulmm ( cax3, cax1,c110, nl ) -! cax3=matmul(cax1,c110) - call resmm ( alf11, cax2,cax3, nl ) - - call diago ( cax1, e210, nl ) - call mulmm ( cax3, cax1,c210, nl ) -! cax3=matmul(cax1,c210) - call resmm ( alf21, cax2,cax3, nl ) - - call diago ( cax1, e310, nl ) - call mulmm ( cax3, cax1,c310, nl ) -! cax3=matmul(cax1,c310) - call resmm ( alf31, cax2,cax3, nl ) - ! - call diago ( cax1, e410, nl ) - call mulmm ( cax3, cax1,c410, nl ) -! cax3=matmul(cax1,c410) - call resmm ( alf41, cax2,cax3, nl ) - ! -! if(ig.eq.2223.and.input_cza.eq.1) then -! open(168,file='output_curtis_c121diagminus2.dat') -! do i=1,nl -! do j=1,nl -! write(168,*)i,j,c110(i,j),c121(i,j) -! enddo -! enddo -! close(168) -! open(178,file='output_taustar.dat') -! do i=1,nl -! write(178,*)i,taustar21(i),taustar31(i),taustar41(i) -! enddo -! close(178) -! endif - if (input_cza.ge.1) then - call diago ( cax1, e121, nl ) - call mulmm ( cax3, cax1,c121, nl ) -! cax3=matmul(cax1,c121) - call resmm ( alf12, cax2,cax3, nl ) - endif - - !! Paso 1 : Calculo de vectores y matrices con 1 barra (aa***) - - if (input_cza.eq.0) then ! Skip paso 1, pues el12 no se calcula - - ! el11 - call sypvvv( aa11, a11,e110,sl110, nl ) - call samem( aa1121, a1121, nl ) - call samem( aa1131, a1131, nl ) - call samem( aa1141, a1141, nl ) - call samem( aalf11, alf11, nl ) - - ! el21 - call sypvvv( aa21, a21,e210,sl210, nl ) - call samem( aa2111, a2111, nl ) - call samem( aa2131, a2131, nl ) - call samem( aa2141, a2141, nl ) - call samem( aalf21, alf21, nl ) - - ! el31 - call sypvvv( aa31, a31,e310,sl310, nl ) - call samem( aa3111, a3111, nl ) - call samem( aa3121, a3121, nl ) - call samem( aa3141, a3141, nl ) - call samem( aalf31, alf31, nl ) - - ! el41 - call sypvvv( aa41, a41,e410,sl410, nl ) - call samem( aa4111, a4111, nl ) - call samem( aa4121, a4121, nl ) - call samem( aa4131, a4131, nl ) - call samem( aalf41, alf41, nl ) - - - else ! (input_cza.ge.1) , FH ! - - - call sypvvv( v1, a12,e121,sl121, nl ) ! a12 + e121 * sl121 - - ! aa11 - call sypvvv( v2, a11,e110,sl110, nl ) - call trucommvv( aa11 , alf12,a1112,v2, v1, nl ) - - ! aalf11 - call invdiag( cax1, a1112, nl ) - call mulmm( cax2, alf12, cax1, nl ) ! alf12 * (1/a1112) -! cax2=matmul(alf12,cax1) - call mulmm( cax3, cax2, alf11, nl ) -! cax3=matmul(cax2,alf11) - - call resmm( aalf11, cax3, a1211, nl ) - ! aa1121 - call trucodiag(aa1121, alf12,a1112,a1121, a1221, nl) - ! aa1131 - call trucodiag(aa1131, alf12,a1112,a1131, a1231, nl) - ! aa1141 - call trucodiag(aa1141, alf12,a1112,a1141, a1241, nl) - - - ! aa21 - call sypvvv( v2, a21,e210,sl210, nl ) - call trucommvv( aa21 , alf12,a2112,v2, v1, nl ) - - ! aalf21 - call invdiag( cax1, a2112, nl ) - call mulmm( cax2, alf12, cax1, nl ) ! alf12 * (1/a2112) -! cax2=matmul(alf12,cax1) - call mulmm( cax3, cax2, alf21, nl ) -! cax3=matmul(cax2,alf21) - call resmm( aalf21, cax3, a1221, nl ) - ! aa2111 - call trucodiag(aa2111, alf12,a2112,a2111, a1211, nl) - ! aa2131 - call trucodiag(aa2131, alf12,a2112,a2131, a1231, nl) - ! aa2141 - call trucodiag(aa2141, alf12,a2112,a2141, a1241, nl) - - - ! aa31 - call sypvvv( v2, a31,e310,sl310, nl ) - call trucommvv( aa31 , alf12,a3112,v2, v1, nl ) - ! aalf31 - call invdiag( cax1, a3112, nl ) - call mulmm( cax2, alf12, cax1, nl ) ! alf12 * (1/a3112) -! cax2=matmul(alf12,cax1) - call mulmm( cax3, cax2, alf31, nl ) -! cax3=matmul(cax2,alf31) - call resmm( aalf31, cax3, a1231, nl ) - ! aa3111 - call trucodiag(aa3111, alf12,a3112,a3111, a1211, nl) - ! aa3121 - call trucodiag(aa3121, alf12,a3112,a3121, a1221, nl) - ! aa3141 - call trucodiag(aa3141, alf12,a3112,a3141, a1241, nl) - - - ! aa41 - call sypvvv( v2, a41,e410,sl410, nl ) - call trucommvv( aa41 , alf12,a4112,v2, v1, nl ) - ! aalf41 - call invdiag( cax1, a4112, nl ) - call mulmm( cax2, alf12, cax1, nl ) ! alf12 * (1/a4112) -! cax2=matmul(alf12,cax1) - call mulmm( cax3, cax2, alf41, nl ) -! cax3=matmul(cax2,alf41) - call resmm( aalf41, cax3, a1241, nl ) - ! aa4111 - call trucodiag(aa4111, alf12,a4112,a4111, a1211, nl) - ! aa4121 - call trucodiag(aa4121, alf12,a4112,a4121, a1221, nl) - ! aa4131 - call trucodiag(aa4131, alf12,a4112,a4131, a1231, nl) - - endif ! Final caso input_cza.ge.1 - - - !! Paso 2 : Calculo de vectores y matrices con 2 barras (aaa***) - - ! aaalf41 - call invdiag( cax1, aa4121, nl ) - call mulmm( cax2, aalf21, cax1, nl ) ! alf21 * (1/a4121) -! cax2=matmul(aalf21,cax1) - call mulmm( cax3, cax2, aalf41, nl ) -! cax3=matmul(cax2,aalf41) - call resmm( aaalf41, cax3, aa2141, nl ) - ! aaa41 - call trucommvv(aaa41, aalf21,aa4121,aa41, aa21, nl) - ! aaa4111 - call trucodiag(aaa4111, aalf21,aa4121,aa4111, aa2111, nl) - ! aaa4131 - call trucodiag(aaa4131, aalf21,aa4121,aa4131, aa2131, nl) - - ! aaalf31 - call invdiag( cax1, aa3121, nl ) - call mulmm( cax2, aalf21, cax1, nl ) ! alf21 * (1/a3121) -! cax2=matmul(aalf21,cax1) - call mulmm( cax3, cax2, aalf31, nl ) -! cax3=matmul(cax2,aalf31) - call resmm( aaalf31, cax3, aa2131, nl ) - ! aaa31 - call trucommvv(aaa31, aalf21,aa3121,aa31, aa21, nl) - ! aaa3111 - call trucodiag(aaa3111, aalf21,aa3121,aa3111, aa2111, nl) - ! aaa3141 - call trucodiag(aaa3141, aalf21,aa3121,aa3141, aa2141, nl) - - ! aaalf11 - call invdiag( cax1, aa1121, nl ) - call mulmm( cax2, aalf21, cax1, nl ) ! alf21 * (1/a1121) -! cax2=matmul(aalf21,cax1) - call mulmm( cax3, cax2, aalf11, nl ) -! cax3=matmul(cax2,aalf11) - call resmm( aaalf11, cax3, aa2111, nl ) - ! aaa11 - call trucommvv(aaa11, aalf21,aa1121,aa11, aa21, nl) - ! aaa1131 - call trucodiag(aaa1131, aalf21,aa1121,aa1131, aa2131, nl) - ! aaa1141 - call trucodiag(aaa1141, aalf21,aa1121,aa1141, aa2141, nl) - - - !! Paso 3 : Calculo de vectores y matrices con 3 barras (aaaa***) - - ! aaaalf41 - call invdiag( cax1, aaa4131, nl ) - call mulmm( cax2, aaalf31, cax1, nl ) ! aaalf31 * (1/aaa4131) -! cax2=matmul(aaalf31,cax1) - call mulmm( cax3, cax2, aaalf41, nl ) -! cax3=matmul(cax2,aaalf41) - call resmm( aaaalf41, cax3, aaa3141, nl ) - - ! aaaa41 - call trucommvv(aaaa41, aaalf31,aaa4131,aaa41, aaa31, nl) - ! aaaa4111 - call trucodiag(aaaa4111, aaalf31,aaa4131,aaa4111,aaa3111, nl) - - ! aaaalf11 - call invdiag( cax1, aaa1131, nl ) - call mulmm( cax2, aaalf31, cax1, nl ) ! aaalf31 * (1/aaa4131) -! cax2=matmul(aaalf31,cax1) - call mulmm( cax3, cax2, aaalf11, nl ) -! cax3=matmul(cax2,aaalf11) - call resmm( aaaalf11, cax3, aaa3111, nl ) - ! aaaa11 - call trucommvv(aaaa11, aaalf31,aaa1131,aaa11, aaa31, nl) - ! aaaa1141 - call trucodiag(aaaa1141, aaalf31,aaa1131,aaa1141,aaa3141, nl) - - - !! Paso 4 : Calculo de vectores y matrices finales y calculo de J1 - - call trucommvv(v1, aaaalf41,aaaa1141,aaaa11, aaaa41, nl) - ! - call invdiag( cax1, aaaa1141, nl ) - call mulmm( cax2, aaaalf41, cax1, nl ) ! aaaalf41 * (1/aaaa1141) -! cax2=matmul(aaaalf41,cax1) - call mulmm( cax3, cax2, aaaalf11, nl ) -! cax3=matmul(cax2,aaaalf11) - call resmm( cax1, cax3, aaaa4111, nl ) - ! - call LUdec ( el11, cax1, v1, nl, nl2 ) - - ! Solucion para el41 - call sypvmv( v1, aaaa41, aaaa4111,el11, nl ) - call LUdec ( el41, aaaalf41, v1, nl, nl2 ) - - ! Solucion para el31 - call sypvmv( v2, aaa31, aaa3111,el11, nl ) - call sypvmv( v1, v2, aaa3141,el41, nl ) - call LUdec ( el31, aaalf31, v1, nl, nl2 ) - - ! Solucion para el21 - call sypvmv( v3, aa21, aa2111,el11, nl ) - call sypvmv( v2, v3, aa2131,el31, nl ) - call sypvmv( v1, v2, aa2141,el41, nl ) - call LUdec ( el21, aalf21, v1, nl, nl2 ) - - !!! - el11(1) = planckdp( t(1), nu11 ) - el21(1) = planckdp( t(1), nu21 ) - el31(1) = planckdp( t(1), nu31 ) - el41(1) = planckdp( t(1), nu41 ) - el11(nl) = 2.d0 * el11(nl-1) - el11(nl2) - el21(nl) = 2.d0 * el21(nl-1) - el21(nl2) - el31(nl) = 2.d0 * el31(nl-1) - el31(nl2) - el41(nl) = 2.d0 * el41(nl-1) - el41(nl2) - - call mulmv ( v1, c110,el11, nl ) - call sumvv ( hr110, v1,sl110, nl ) - - ! Solucion para el12 - if (input_cza.ge.1) then - - call sypvmv( v1, a12, a1211,el11, nl ) - call sypvmv( v3, v1, a1221,el21, nl ) - call sypvmv( v2, v3, a1231,el31, nl ) - call sypvmv( v1, v2, a1241,el41, nl ) - call LUdec ( el12, alf12, v1, nl, nl2 ) - - el12(1) = planckdp( t(1), nu121 ) - el12(nl) = 2.d0 * el12(nl-1) - el12(nl2) - - if (itt_cza.eq.15) then - call mulmv ( v1, c121,el12, nl ) - call sumvv ( hr121, v1,sl121, nl ) - endif - - end if - - - - if (input_cza.lt.1) then - - do i=1,nl - pl11 = el11(i)/dble( gamma * nu11**3.0d0 * 1./2. / n10(i) ) - pl21 = el21(i)/dble( gamma * nu21**3.0d0 * 1./2. / n20(i) ) - pl31 = el31(i)/dble( gamma * nu31**3.0d0 * 1./2. / n30(i) ) - pl41 = el41(i)/dble( gamma * nu41**3.0d0 * 1./2. / n40(i) ) - vt11(i) = dble(-ee*nu11) / log( abs(pl11) / (2.0d0*n10(i)) ) - vt21(i) = dble(-ee*nu21) / log( abs(pl21) / (2.0d0*n20(i)) ) - vt31(i) = dble(-ee*nu31) / log( abs(pl31) / (2.0d0*n30(i)) ) - vt41(i) = dble(-ee*nu41) / log( abs(pl41) / (2.0d0*n40(i)) ) - hr210(i) = sl210(i) - hplanck*vlight*nu21 * a21_einst(i)*pl21 - hr310(i) = sl310(i) - hplanck*vlight*nu31 * a31_einst(i)*pl31 - hr410(i) = sl410(i) - hplanck*vlight*nu41 * a41_einst(i)*pl41 -! hr410(i) = 0. - enddo - - call dinterconnection ( v626t1, vt11 ) - call dinterconnection ( v628t1, vt21 ) - call dinterconnection ( v636t1, vt31 ) - call dinterconnection ( v627t1, vt41 ) - - else - - do i=1,nl - pl21 = el21(i)/dble( gamma * nu21**3.0d0 * 1./2. / n20(i) ) - pl31 = el31(i)/dble( gamma * nu31**3.0d0 * 1./2. / n30(i) ) - pl41 = el41(i)/dble( gamma * nu41**3.0d0 * 1./2. / n40(i) ) - hr210(i) = sl210(i) - hplanck*vlight*nu21 * a21_einst(i)*pl21 - hr310(i) = sl310(i) - hplanck*vlight*nu31 * a31_einst(i)*pl31 - hr410(i) = sl410(i) - hplanck*vlight*nu41 * a41_einst(i)*pl41 -! hr410(i) = 0. - if (itt_cza.eq.13) then - pl12 = el12(i)/dble( gamma * nu121**3.0d0 * 2./4. / n11(i) ) - hr121(i) = - hplanck*vlight * nu121 * a12_einst(i) * pl12 - hr121(i) = hr121(i) + sl121(i) - endif - enddo - - endif - - ! K/Dday - do i=1,nl - hr110(i)=hr110(i)*( hrkday_factor(i) / nt(i) ) - hr210(i)=hr210(i)*( hrkday_factor(i) / nt(i) ) - hr310(i)=hr310(i)*( hrkday_factor(i) / nt(i) ) - hr410(i)=hr410(i)*( hrkday_factor(i) / nt(i) ) - hr121(i)=hr121(i)*( hrkday_factor(i) / nt(i) ) - end do - - - -c output - - !codigo = codeout - !call dmzout_tv ( 1 ) - !call dmzout_hr ( 1 ) - -c final subrutina - return - end Index: trunk/LMDZ.MARS/libf/phymars/NLTEdlvr09_TCOOL.F =================================================================== --- trunk/LMDZ.MARS/libf/phymars/NLTEdlvr09_TCOOL.F (revision 496) +++ (revision ) @@ -1,123 +1,0 @@ -c*********************************************************************** - - subroutine NLTEdlvr09_TCOOL (ngridgcm,n_gcm, - @ p_gcm, t_gcm, z_gcm, - @ co2vmr_gcm, n2vmr_gcm, covmr_gcm, o3pvmr_gcm, - @ q15umco2_gcm ) - -c jul 2011 malv+fgg -c*********************************************************************** - - implicit none - - include "dimensions.h" - include "dimphys.h" - include 'nltedefs.h' - include 'nlte_atm.h' - include 'nlte_results.h' - include 'tcr_15um.h' - include 'nlte_matrix.h' - include 'nlte_data.h' - include "chimiedata.h" - include "conc.h" - -c Arguments - integer n_gcm,ngridgcm - real p_gcm(ngridgcm,n_gcm), t_gcm(ngridgcm,n_gcm) - real co2vmr_gcm(ngridgcm,n_gcm), n2vmr_gcm(ngridgcm,n_gcm) - real covmr_gcm(ngridgcm,n_gcm), o3pvmr_gcm(ngridgcm,n_gcm) - real q15umco2_gcm(ngridgcm,n_gcm) - real z_gcm(ngridgcm,n_gcm) - -c local variables and constants - integer iz, i, j, k, l, ig,istyle - - real*8 q15umco2_nl(nl) - real*8 zld(nl), zgcmd(n_gcm) - real*8 auxdgcm(n_gcm) - - - real p_ig(n_gcm),z_ig(n_gcm) - real t_ig(n_gcm) - real co2_ig(n_gcm),n2_ig(n_gcm),co_ig(n_gcm),o3p_ig(n_gcm) - real mmean_ig(n_gcm),cpnew_ig(n_gcm) - - -c********************************************************************** - - do ig=1,ngridgcm - do l=1,n_gcm - p_ig(l)=p_gcm(ig,l) - t_ig(l)=t_gcm(ig,l) - co2_ig(l)=co2vmr_gcm(ig,l) - n2_ig(l)=n2vmr_gcm(ig,l) - o3p_ig(l)=o3pvmr_gcm(ig,l) - co_ig(l)=covmr_gcm(ig,l) - z_ig(l)=z_gcm(ig,l)/1000. - mmean_ig(l)=mmean(ig,l) - cpnew_ig(l)=cpnew(ig,l) - enddo - - call NLTEdlvr09_ZGRID (n_gcm, - @ p_ig, t_ig, z_ig, - @ co2_ig,n2_ig,co_ig, - $ o3p_ig , mmean_ig, cpnew_ig) - -c And sets zero to all Curtis Matrixes and Escape Transmissions - call leetvt - call zero3m (c110,cup110,cdw110, nl) - call zero2v (taugr110,vc110, nl) - if (itt_cza.eq.24) then - call mzescape ( ig,taustar11,tauinf110,tauii110, - @ 1, 1,irw_mztf,imu ) - istyle=2 - call mzescape_normaliz ( taustar11, istyle ) - else - call mztud (ig, c110,cup110,cdw110, vc110,taugr110, - @ 1, 1, irw_mztf, imu, 0,0,0 ) - endif - call mztvc (ig,vc210, 1, 2, irw_mztf, imu, 0,0,0 ) - call mztvc (ig,vc310, 1, 3, irw_mztf, imu, 0,0,0 ) - call mztvc (ig,vc410, 1, 4, irw_mztf, imu, 0,0,0 ) - call mzescape_fb (ig) - input_cza = 0 - call NLTEdlvr09_CZALU(ig) - - if (itt_cza.ne.24) then - call mzescape_fh (ig) - input_cza = 1 - call NLTEdlvr09_CZALU(ig) - endif - - -c total cooling rate -c smoothing and -c interpolation back to original Pgrid -c - do i = 1, nl - q15umco2_nl(i) = hr110(i) + hr210(i) + hr310(i) + hr410(i) - @ + hr121(i) - enddo - - do i=1,nl - zld(i) = - dble ( alog(pl(i)) ) - enddo - do i=1,n_gcm - zgcmd(i) = - dble( alog(p_gcm(ig,i)) ) - enddo - call zerov( auxdgcm, n_gcm ) - call interdp_limits - @ ( auxdgcm, zgcmd, n_gcm, jlowerboundary,jtopboundary, - @ q15umco2_nl, zld, nl, 1,nl, 1 ) - call suaviza ( auxdgcm, n_gcm, 1, zgcmd ) - - do i=1,n_gcm - q15umco2_gcm(ig,i) = sngl( auxdgcm(i) ) - enddo - - enddo - - -c end subroutine - return - end Index: trunk/LMDZ.MARS/libf/phymars/NLTEdlvr09_ZGRID.F =================================================================== --- trunk/LMDZ.MARS/libf/phymars/NLTEdlvr09_ZGRID.F (revision 496) +++ (revision ) @@ -1,149 +1,0 @@ -c*********************************************************************** - - subroutine NLTEdlvr09_ZGRID (n_gcm, - @ p_gcm, t_gcm, z_gcm, - @ co2vmr_gcm, n2vmr_gcm, covmr_gcm, o3pvmr_gcm ,mmean_gcm, - @ cpnew_gcm) - -c jul 2011 malv+fgg First version -c*********************************************************************** - - implicit none - - include "dimensions.h" - include "dimphys.h" - include 'nltedefs.h' - include 'nlte_atm.h' - include 'tcr_15um.h' - include 'nlte_data.h' - include 'chimiedata.h' - include 'conc.h' - -c Arguments - integer n_gcm - real p_gcm(n_gcm), t_gcm(n_gcm) - real co2vmr_gcm(n_gcm), n2vmr_gcm(n_gcm) - real covmr_gcm(n_gcm), o3pvmr_gcm(n_gcm) - real z_gcm(n_gcm) - real mmean_gcm(n_gcm) - real cpnew_gcm(n_gcm) - -c local variables - integer i, j , iz -! real distancia, meanm, gz, Hkm - real zmin, zmax, deltazz, deltazzy - real nt_gcm(n_gcm) - real mmean_nlte(n_gcm),cpnew_nlte(n_gcm) - -c functions - external hrkday_convert - real hrkday_convert - -c*********************************************************************** - - -! Define working grid for MZ1D model (NL, ZL, ZMIN) -! y otro mas fino para M.Curtis (NZ, ZX, ZXMIN = ZMIN - -! Para ello hace falta una z de ref del GCM, que voy a suponer la inferior - -! Primero, construimos escala z_gcm - -! z_gcm (1) = zmin_gcm ! [km] - - !write (*,*) ' iz, p, g, H, z =', 1, p_gcm(1), z_gcm(1) -! do iz = 2, n_gcm -! do iz=1,n_gcm -! z_gcm(iz)=zlay(iz)/1.e3 - -! meanm = ( co2vmr_gcm(iz)*44. + o3pvmr_gcm(iz)*16. -! @ + n2vmr_gcm(iz)*28. + covmr_gcm(iz)*28. ) -! meanm = meanm / n_avog -! distancia = ( radio + z_gcm(iz-1) )*1.e5 -! gz = gg * masa / ( distancia * distancia ) -! Hkm = 0.5*( t_gcm(iz)+t_gcm(iz-1) ) / ( meanm * gz ) -! Hkm = kboltzman * Hkm *1e-5 ! [km] -! z_gcm(iz) = z_gcm(iz-1) - Hkm * log( p_gcm(iz)/p_gcm(iz-1) ) - - !write (*,*) iz, p_gcm(iz), gz, Hkm, z_gcm(iz) - -! enddo -! Segundo, definimos los límites del modelo, entre las 2 presiones clave - - ! Bottom boundary for NLTE model : Pbottom=2e-2mb=1.974e-5 atm - jlowerboundary = 1 - do while ( p_gcm(jlowerboundary) .gt. Pbottom_atm ) - jlowerboundary = jlowerboundary + 1 - enddo - zmin = z_gcm(jlowerboundary) -! write (*,*) ' jlowerboundary, Pmin, zmin =', -! @ jlowerboundary, p_gcm(jlowerboundary), zmin - - ! Top boundary for NLTE model : Ptop=2e-7mb = 1.974e-5 atm - jtopboundary = jlowerboundary - do while ( p_gcm(jtopboundary) .gt. Ptop_atm ) - jtopboundary = jtopboundary + 1 - enddo - zmax = z_gcm(jtopboundary) -! write (*,*) ' jtopboundary, Pmax, zmax =', -! @ jtopboundary, p_gcm(jtopboundary),zmax - - deltaz = (zmax-zmin) / (nl-1) - do i=1,nl - zl(i) = zmin + (i-1) * deltaz - enddo -! write (*,*) ' ZL grid: dz,zmin,zmax ', deltaz, zl(1),zl(nl) -! Creamos el perfil interpolando - call intersp ( pl,zl,nl, p_gcm,z_gcm,n_gcm, 2) ! [atm] - call intersp ( t,zl,nl, t_gcm,z_gcm,n_gcm, 1) - do i = 1, n_gcm - nt_gcm(i) = 7.339e+21 * p_gcm(i) / t_gcm(i) ! [cm-3] - enddo - call intersp ( nt,zl,nl, nt_gcm,z_gcm,n_gcm, 2) - call intersp (co2vmr,zl,nl, co2vmr_gcm,z_gcm,n_gcm, 1) - call intersp ( n2vmr,zl,nl, n2vmr_gcm,z_gcm,n_gcm, 1) - call intersp ( covmr,zl,nl, covmr_gcm,z_gcm,n_gcm, 1) - call intersp (o3pvmr,zl,nl, o3pvmr_gcm,z_gcm,n_gcm, 1) - call intersp (mmean_nlte,zl,nl,mmean_gcm,z_gcm,n_gcm,1) - call intersp (cpnew_nlte,zl,nl,cpnew_gcm,z_gcm,n_gcm,1) - - - do i = 1, nl - - co2(i) = nt(i) * co2vmr(i) - n2(i) = nt(i) * n2vmr(i) - co(i) = nt(i) * covmr(i) - o3p(i) = nt(i) * o3pvmr(i) - -! hrkday_factor(i) = hrkday_convert( t(i), -! @ co2vmr(i), o3pvmr(i), n2vmr(i), covmr(i) ) - hrkday_factor(i) = hrkday_convert (mmean_nlte(i),cpnew_nlte(i)) - - enddo - - - -c Fine grid for transmittance calculations - - deltazy = (zmax-zmin) / (nzy-1) - do i=1,nzy - zy(i) = zmin + (i-1) * deltazy - enddo -! write (*,*) ' ZY grid: nzy,dzy,zmin,zmax ', -! @ nzy, deltazy, zy(1),zy(nzy) - - call intersp ( py,zy,nzy, p_gcm,z_gcm,n_gcm, 2) ! [atm] - call intersp ( ty,zy,nzy, t_gcm,z_gcm,n_gcm, 1) - call intersp ( nty,zy,nzy, nt_gcm,z_gcm,n_gcm, 2) - - call intersp ( co2y,zy,nzy, co2vmr_gcm,z_gcm,n_gcm, 1) - do i=1,nzy - co2y(i) = co2y(i) * nty(i) - enddo - - - - -c end - return - end Index: trunk/LMDZ.MARS/libf/phymars/bloque.F =================================================================== --- trunk/LMDZ.MARS/libf/phymars/bloque.F (revision 496) +++ (revision ) @@ -1,66 +1,0 @@ -c*********************************************************************** - block data bloque - -c reads planetary and molecular parameters - -c jan 98 malv first version -c jul 2011 malv+fgg Adapted to LMD-MGCM -c*********************************************************************** - - implicit none - - include 'nltedefs.h' - include 'nlte_data.h' - -c data - data nu(1,1),nu(1,2),nu(1,3),nu(1,4) - @ /667.3801, 1335.1317, 2003.2463, 2349.1433/ - data nu(1,5),nu(1,6),nu(1,7),nu(1,8) - @ /3004.0112, 3612.8417, 3659.2728, 3714.7828/ - data nu(2,1),nu(2,2),nu(2,3),nu(2,4) - @ /662.3734, 1325.1410, 1988.3280, 2332.1128/ - data nu(2,5),nu(2,6),nu(2,7),nu(2,8) - @ /2982.1115, 3571.1404, 3632.5240, 3675.1332/ - data nu(3,1),nu(3,2),nu(3,3),nu(3,4) - @ /648.4784, 1297.2640, 1946.3507, 2283.4876/ - data nu(3,5),nu(3,6),nu(3,7),nu(3,8) - @ /2920.2387, 3527.7380, 3557.3145, 3632.9112/ - data nu(4,1),nu(4,2),nu(4,3),nu(4,4) - @ /664.7289, 1329.8430, 1995.3520, 2340.0136/ - data nu(4,5),nu(4,6),nu(4,7),nu(4,8) - @ /2992.3100, 3591.2510, 3644.9900, 3693.3460/ - data nu12_0200,nu12_1000, nu22_0200,nu22_1000 - @ /1285.4087, 1388.1847, 1259.4257, 1365.8439/ - data nu32_0200,nu32_1000, nu42_0200,nu42_1000 - @ /1265.8282, 1370.0626, 1272.2866, 1376.0275/ - data nun2, nuco_10 - @ /2331.0, 2143.2716 / - data deltanuco/306./ - - data indexisot/26,28,36,27/ - - ! ctes en el sistema cgs - data vlight, ee /2.9979245e10, 1.43876866/ - data hplanck, gamma/6.6260755e-27, 1.191043934e-5/ - - - ! datos de marte - data imrco / 0.9865 / - data imr / 0.987, 0.00408, 0.0112, 0.000742 / - - ! datos de venus - !data radio / 6052. / ! radio [km] - !data mean_distance / 0.723 / ! mean heliocentric distance [AU] - !data amplitude_excentricity / 0.0 / ! [AU] - !data phase_equinox / 0.0 / ! [degree] - !data period_rot / 2.15404e7 / ! period_rot [s] (=243 [Earth days]) - !OJO! El periodo es realmente 116 days - ! pues se combinan la rotacion (243 d) - ! con la traslacion (xxx d) - !data planet_inclination / 3.39 / ! [degree] - !data masa / 2.53104e27 / ! masa [g] - !data imr, imrco / 0.987, 0.00408, 0.0112, 0.000742, 0.9865 / - !data imr637,imr638,imr828,imr728 /9.e-6, 4.4e-5, 4.e-6, 2.e-6/ - - - end Index: trunk/LMDZ.MARS/libf/phymars/cm15um_hb_simple.F =================================================================== --- trunk/LMDZ.MARS/libf/phymars/cm15um_hb_simple.F (revision 496) +++ (revision ) @@ -1,201 +1,0 @@ -c*********************************************************************** - - subroutine cm15um_hb_simple (ig,icurt) - -c computing the curtix matrixes for the 15 um hot bands -c (las de las bandas fudnamentales las calcula cm15um_fb) - -c jan 98 malv version de mod3/cm_15um.f para mz1d -c jul 2011 malv+fgg adapted to LMD-MGCM -c*********************************************************************** - - implicit none - -!!!!!!!!!!!!!!!!!!!!!!! -! common variables & constants - - include 'nltedefs.h' - include 'nlte_atm.h' - include 'nlte_data.h' -! include '../CMN/tcr_15um.cmn' - include 'tcr_15um.h' - include 'nlte_results.h' - include 'nlte_matrix.h' - include 'nlte_curtis.h' - -!!!!!!!!!!!!!!!!!!!!!!! -! arguments - - integer ig ! ADDED FOR TRACEBACK - integer icurt ! icurt=0,1,2 - ! new calculations? (see caa.f heads) - -!!!!!!!!!!!!!!!!!!!!!!! -! local variables - - real*4 cdummy(nl,nl), csngl(nl,nl) - - real*8 cax1(nl,nl), cax2(nl,nl), cax3(nl,nl) - real*8 v1(nl), v2(nl), v3(nl), cm_factor, vc_factor - - integer itauout,icfout,itableout, interpol,ismooth, isngldble - integer i,j,ik,ist,isot,ib,itt - - !character bandcode*2 - character isotcode*2 - character codmatrx_hot*5 - -!!!!!!!!!!!!!!!!!!!!!!! -! external functions - - external bandid - character*2 bandid - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! subroutines called: -! mz4sub, dmzout, readc_mz4, readcupdw, mztf - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! formatos - 132 format(i2) - -************************************************************************ -************************************************************************ - - call zerom (c121,nl) - - call zerov (vc121,nl) - - call zerom (cup121,nl) - call zerom (cdw121,nl) - - call zerov (taugr121,nl) - - - itauout = 0 ! =1 --> with output of tau - icfout = 0 ! =1 --> with output of cf - itableout = 0 ! =1 --> with output of table of taus - isngldble = 1 ! =1 --> dble precission - - codmatrx_hot=' ' - if (icurt.eq.2) then - icfout=1 - elseif (icurt.eq.0) then - write (*,'(a,a$)') - @ ' hot bands. code for old matrixes (5 chars): ' - read (*,'(a)') codmatrx_hot - endif - - fileroot = 'cfl' - -! ====================== curtis matrixes for fh bands ================== - - -! una piedra en el camino ... -! write (*,*) ' cm15um_hb/1 ' - -ccc - if ( input_cza.ge.1 ) then -ccc - - if (icurt.eq.2) then - write (*,'(a,a$)') - @ ' new calculation of curt. mat. for fh bands.', - @ ' code for new matrixes : ' - read (*,'(a)') codmatrx_hot - elseif (icurt.eq.0) then - write (*,'(a,a$)') - @ ' reading in curt. mat. for fh bands.', - @ ' code for old matrixes : ' - read (*,'(a)') codmatrx_hot - else -! write (*,'(a)') -! @ ' new calculation of curt. mat. for fh bands.' - end if - -! fh bands for the 626 isotope ================================- - - ist = 1 - isot = 26 -! encode (2,132,isotcode) isot - write (isotcode,132) isot - - do 11, ik=1,3 - - ib=ik+1 - - if (icurt.gt.0) then - call zero3m (cax1,cax2,cax3,nl) -! una piedra en el camino ... - !write (*,*) ' cm15um_hb/11 ' - !write (*,*) ' ib, ist, irw, imu =', ib, ist, irw_mztf, imu - call mztf ( ig,cax1,cax2,cax3,v1,v2, ib,ist,irw_mztf,imu, - @ itauout,icfout,itableout) -! else -! bandcode = bandid(ib) -! filend=isotcode//dn//bandcode//codmatrx_hot -!! write (*,*) char(9), fileroot//filend -! call zero3m (cax1,cax2,cax3,nl) -! call readcud_mz1d ( cax1,cax2,cax3, v1, v2, -! @ fileroot,filend, csngl, nl,nan,0,isngldble) - end if - -c calculating the total c121(n,r) matrix for the first hot band - do i=1,nl - - if ( ib .eq. 4 ) then -! write (*,*) ' ' -! write (*,*) i, ' ib,ist, altura :', ib,ist, zl(i) - endif - -! if ( v1(i) .le. 1.d-99 ) v1(i) = 0.0d0 -! if ( v2(i) .le. 1.d-99 ) v2(i) = 0.0d0 - - - if(ik.eq.1)then - cm_factor = (dble(618.03/667.75))**2.d0* - @ exp( dble(ee*(667.75-618.03)/t(i)) ) - vc_factor = dble(667.75/618.03) - elseif(ik.eq.2)then - cm_factor = 1.d0 - vc_factor = 1.d0 - elseif(ik.eq.3)then - cm_factor = ( dble(720.806/667.75) )**2.d0* - @ exp( dble(ee*(667.75-720.806)/t(i)) ) - vc_factor = dble(667.75/720.806) - end if - do j=1,nl -! if (cax1(i,j) .le. 1.d-99 ) cax1(i,j) = 0.0d0 -! if (cax2(i,j) .le. 1.d-99 ) cax2(i,j) = 0.0d0 -! if (cax3(i,j) .le. 1.d-99 ) cax3(i,j) = 0.0d0 - c121(i,j) = c121(i,j) + cax1(i,j) * cm_factor - cup121(i,j) = cup121(i,j) + cax2(i,j) * cm_factor - cdw121(i,j) = cdw121(i,j) + cax3(i,j) * cm_factor - end do - -! write (*,*) ' i =', i -! write (*,*) ' vc_factor =', vc_factor -! write (*,*) ' v1 =', v1(i) -! write (*,*) ' v2 =', v2(i) -! write (*,*) vc121(i), taugr121(i) -! write (*,*) v1(i) * vc_factor -! write (*,*) vc121(i) + v1(i) * vc_factor - - vc121(i) = vc121(i) + v1(i) * vc_factor - - -! write (*,*) v2(i) * vc_factor -! write (*,*) taugr121(i) + v2(i) * vc_factor - - taugr121(i) = taugr121(i) + v2(i) * vc_factor - - end do -11 continue - -ccc - end if -ccc - - - return - end Index: trunk/LMDZ.MARS/libf/phymars/einsteincoefs.h =================================================================== --- trunk/LMDZ.MARS/libf/phymars/einsteincoefs.h (revision 496) +++ (revision ) @@ -1,194 +1,0 @@ -c********************************************************************** -c* -c* Einstein coefficients -c* -c* fgg mar 2010 (adapted from MALV get_a subroutine) -c* -c********************************************************************** -c -! isotope 626 for this isotope the values are from mlp -c - real*8 a1_103, a1_102, a1_101, a1_023, a1_022, a1_021 -c - parameter (a1_103 = 1260.d0) - parameter (a1_102 = 820.d0) - parameter (a1_101 = 410.d0) - parameter (a1_023 = 1220.d0) - parameter (a1_022 = 814.d0) - parameter (a1_021 = 406.d0) -c -c - real*8 a1_003, a1_002, a1_301, a1_221, a1_141, a1_061 -c - parameter (a1_003 = 1200.d0) - parameter (a1_002 = 780.d0) - parameter (a1_301 = 400.d0) - parameter (a1_221 = 400.d0) - parameter (a1_141 = 400.d0) - parameter (a1_061 = 400.d0) -c -c - real*8 a1_201, a1_121, a1_041, a1_220, a1_130, a1_050 -c - parameter (a1_201 = 424.d0) - parameter (a1_121 = 418.d0) - parameter (a1_041 = 418.d0) - parameter (a1_220 = 1.43d0) - parameter (a1_130 = 2.3d0) - parameter (a1_050 = 7.15d0) -c -c - real*8 a1_120, a1_55, a1_44, a1_300, a1_a43, a1_210, a1_200 -c - parameter (a1_120 = 2.08d0) - parameter (a1_55 = (5.67d0+a1_120)/2.d0) - parameter (a1_44 = 3.68d0) - parameter (a1_300 = 4.3d0) - parameter (a1_a43 = 2.44d0) - parameter (a1_210 = a1_a43+a1_44) - parameter (a1_200 = 4.53d0) -c -c - real*8 a1_140, a1_060, a1_0510, a1_040, a1_0420, a1_1220 -c - parameter (a1_140 = 2.27d0) - parameter (a1_060 = 2.32d0) - parameter (a1_0510 = a1_0510_0420+a1_0510_0400) - parameter (a1_040 = 2.35d0) - parameter (a1_0420 = 3.3d0) - parameter (a1_1220 = 4.71d0) -c -c - real*8 a1_1111_1110,a1_1111_0110, a1_0311_0310,a1_0311_0110 -c - parameter (a1_1111_1110 = 367.0d0) - parameter (a1_1111_0110 = 17.0d0) - parameter (a1_0311_0310 = 370.8d0) - parameter (a1_0311_0110 = 9.65d0) -c -c - real*8 a1_0111_010, a1_0201_0200, a1_0201_000, a1_0221_0220 -c - parameter (a1_0111_010 = 388.4d0) - parameter (a1_0201_000 = 10.39d0) - parameter (a1_0201_0200 = 383.756d0) - parameter (a1_0221_0220 = 386.56d0) -c -c - real*8 a1_1001_1000, a1_1001_000, a1_001_000,a1_010_000 -c - parameter (a1_1001_1000 = 381.222d0) - parameter (a1_1001_000 = 16.68d0) - parameter (a1_001_000 = 389.34d0) - parameter (a1_010_000 = 1.3546d0) -c -c - real*8 a1_0421_1220, a1_0421_0420, a1_0421_000 -c - parameter (a1_0421_000 = 0.66d0) - parameter (a1_0421_0420 = 360.5d0) - parameter (a1_0421_1220 = 0.129d0) -c -c - real*8 a1_1221_0111, a1_1221_1220, a1_1221_0420 -c - parameter (a1_1221_0420 = 0.01227d0) - parameter (a1_1221_1220 = 355.2d0) - parameter (a1_1221_0111 = 0.0219d0) -c -c - real*8 a1_0510_000, a1_0510_0420, a1_0510_0400 -c - parameter (a1_0510_000 = 4.d-4) - parameter (a1_0510_0420 = 1.086d0) - parameter (a1_0510_0400 = 2.406d0) -c -c - real*8 a1_0510_1000, a1_0510_0220, a1_0510_0200 - parameter (a1_0510_1000 = 3.44d-5) - parameter (a1_0510_0220 = 6.339d-4) - parameter (a1_0510_0200 = 1.5d-3) -c -c - real*8 a1_1310_000 , a1_1310_0420 , a1_1310_0400 -c - parameter (a1_1310_000 = 4.45d-4) - parameter (a1_1310_0420 = 0.7535d0) - parameter (a1_1310_0400 = 0.21d0) -c -c - real*8 a1_1310_1200 , a1_1310_1220 , a1_1310_2000 -c - parameter (a1_1310_1200 = 2.264d0) - parameter (a1_1310_1220 = 0.3609d0) - parameter (a1_1310_2000 = 0.074d0) -c -c - real*8 a1_1310_0111,a1_1310_1000,a1_1310_0220,a1_1310_0200 -c - parameter (a1_1310_0111 = 1.64d-4) - parameter (a1_1310_1000 = 1.433d-3) - parameter (a1_1310_0220 = 2.4d-4) - parameter (a1_1310_0200 = 9.719d-3) -c -c - real*8 a1_2110_000 , a1_2110_0420 , a1_2110_0400 -c - parameter (a1_2110_000 = 3.265d-4) - parameter (a1_2110_0420 = 6.48d-3) - parameter (a1_2110_0400 = 1.54d-3) -c -c - real*8 a1_2110_1200,a1_2110_1220,a1_2110_2000,a1_2110_0111 -c - parameter (a1_2110_1200 = 0.0738d0) - parameter (a1_2110_1220 = 1.957d0) - parameter (a1_2110_2000 = 3.289d0) - parameter (a1_2110_0111 = 2.68d-4) -c -c - real*8 a1_2110_1000 , a1_2110_0220 , a1_2110_0200 -c - parameter (a1_2110_1000 = 3.445d-2) - parameter (a1_2110_0220 = 1.976d-2) - parameter (a1_2110_0200 = 6.539d-3) -c -c - real*8 a1_0403_0402, a1_0403_0202 -c - parameter (a1_0403_0402 = 728.7d0) - parameter (a1_0403_0202 = 28.9d0) -c - real*8 a1_1203_1202, a1_1203_1002, a1_1203_0202 -c -c - parameter (a1_1203_1202 = 716.3d0) - parameter (a1_1203_1002 = 27.25d0) - parameter (a1_1203_0202 = 43.68d0) -c -c - real*8 a1_2003_2002, a1_2003_1002, a1_2003_0202 -c - parameter (a1_2003_2002 = 995.7d0) - parameter (a1_2003_1002 = 83.27d0) - parameter (a1_2003_0202 = 1.15d0) -c -c - real*8 a1_0402_0401, a1_0402_0201 -c - parameter (a1_0402_0401 = 700.0d0) - parameter (a1_0402_0201 = 28.97d0) -c -c - real*8 a1_1202_1201, a1_1202_1001, a1_1202_0201 -c - parameter (a1_1202_1201 = 687.0d0) - parameter (a1_1202_1001 = 26.07d0) - parameter (a1_1202_0201 = 39.57d0) -c -c - real*8 a1_2002_2001, a1_2002_1001 -c - parameter (a1_2002_2001 = 686.1d0) - parameter (a1_2002_1001 = 54.67d0) - Index: trunk/LMDZ.MARS/libf/phymars/elimin_mz1d.F =================================================================== --- trunk/LMDZ.MARS/libf/phymars/elimin_mz1d.F (revision 496) +++ (revision ) @@ -1,300 +1,0 @@ -c ************************************************************************ - subroutine elimin_mz1d (c,vc, ilayer,nan,itblout, nw) - -c Eliminate anomalous negative numbers in c(nl,nl) according to "nan": - -c nan = 0 -> no eliminate -c @ -> eliminate all numbers with absol.value eliminate all anomalous negative numbers in c(n,r). -c 3 -> eliminate all anomalous negative numbers far from the main -c diagonal. -c 8 -> eliminate all non-zero numbers outside the main diagonal, -c and the contibution of lower boundary. -c 9 -> eliminate all non-zero numbers outside the main diagonal. -c 4 -> hace un smoothing cuando la distancia de separacion entre -c el valor maximo y el minimo de cf > 50 capas. -c 5 -> elimina valores menores que 1.0d-19 -c 6 -> incluye los dos casos 4 y 5 -c 7 -> llama a lisa: smooth con width=nw & elimina mejorado -c 78-> incluye los dos casos 7 y 8 -c 79-> incluye los dos casos 7 y 9 - -c itblout (itableout in calling program) is the option for writing -c out or not the purged c(n,r) matrix: -c itblout = 0 -> no write -c = 1 -> write out in curtis***.out according to ilayer - -c ilayer is the index for the layer selected to write out the matrix: -c ilayer = 0 => matrix elements written out cover all the altitudes -c with 5 layers steps -c > 0 => " " " " are c(ilayer,*) -c NOTA: -c EXISTE LA POSIBILIDAD DE SACAR TODAS LAS CAPAS (TODA LA MATRIZ) -c UTILIZANDO itableout=30 EN MZTUD - -c jul 2011 malv+fgg adapted to LMD-MGCM -c Sep-04 FGG+MALV Correct include and call parameters -c cristina 25-sept-1996 y 27-ene-1997 -c JAN 98 MALV Version for mz1d -c ************************************************************************ - - implicit none - - include 'nltedefs.h' - - integer nan,j,i,itblout,kk,k,ir,in - integer ilayer,jmin, jmax,np,nw,ntimes,ntimes2 -!* real*8 c(nl,nl), vc(nl), amax, cmax, cmin, cs(nl,nl), mini - real*8 c(nl,nl), vc(nl), amax, cmax, cmin, mini - real*8 aux(nl), auxs(nl) - character layercode*3 - - ntimes=0 - ntimes2=0 -! type *,'from elimin_mz4: nan, nw',nan,nw - - if (nan .eq. 0) goto 200 - - if(nan.eq.1)then - do i=1,nl - amax=1.0d-36 - do j=1,nl - if(abs(c(i,j)).gt.amax)amax=abs(c(i,j)) - end do - do j=1,nl - if(abs(c(i,j)).lt.amax/300.0d0)c(i,j)=0.0d0 - end do - enddo - elseif(nan.eq.2)then - do i=1,nl - do j=1,nl - if( ( j.le.(i-2) .or. j.gt.(i+2) ).and. - @ ( c(i,j).lt.0.0d0 ) ) c(i,j)=0.0d0 - end do - enddo - elseif(nan.eq.3)then - do i=1,nl - do j=1,nl - if (abs(i-j).ge.10) c(i,j)=0.0d0 - end do - enddo - elseif(nan.eq.8)then - do i=1,nl - do j=1,i-1 - c(i,j)=0.0d0 - enddo - do j=i+1,nl - c(i,j)=0.0d0 - enddo - vc(i)= 0.d0 - enddo - elseif(nan.eq.9)then - do i=1,nl - do j=1,i-1 - c(i,j)=0.0d0 - enddo - do j=i+1,nl - c(i,j)=0.0d0 - enddo - enddo -! elseif(nan.eq.7.or.nan.eq.78.or.nan.eq.79)then -! call lisa(c, vc, nl, nw) - end if - if(nan.eq.78)then - do i=1,nl - do j=1,i-1 - c(i,j)=0.0d0 - enddo - do j=i+1,nl - c(i,j)=0.0d0 - enddo - vc(i)= 0.d0 - enddo - endif - if(nan.eq.79)then - do i=1,nl - do j=1,i-1 - c(i,j)=0.0d0 - enddo - do j=i+1,nl - c(i,j)=0.0d0 - enddo - enddo - endif - - if(nan.eq.5.or.nan.eq.6)then - do i=1,nl - mini = 1.0d-19 - do j=1,nl - if(abs(c(i,j)).le.mini.and.c(i,j).ne.0.d0) then - ntimes2=ntimes2+1 - end if - if ( abs(c(i,j)).le.mini) c(i,j)=0.d0 - end do - enddo - end if - - if(nan.eq.4.or.nan.eq.6)then - do i=1,nl - do j=1,nl - aux(j)=c(i,j) - auxs(j)=c(i,j) - end do - call maxdp_2(aux,nl,cmax,jmax) - if(abs(jmax-i).ge.50) then - call smooth_cf(aux,auxs,i,nl,3) - !!!call smooth_cf(aux,auxs,i,nl,5) - ntimes=ntimes+1 - end if - do j=1,nl - c(i,j)=auxs(j) - end do - end do - end if - -! type *, 'elimin_mz4: c(n,r) procesed for elimination. ' -! type *, ' ' -! if(nan.eq.4.or.nan.eq.6) type *, ' call smoothing:',ntimes -! if(nan.eq.5.or.nan.eq.6) type *, ' call elimina: ',ntimes2 -! if(nan.eq.7) type *, ' from elimin: lisa w=',nw -! type *, ' ' - - - 200 continue - -c writting out of c(n,r) in ascii file - -! if(itblout.eq.1) then - -! if (ilayer.eq.0) then - -! open (unit=2, status='new', -! @ file=dircurtis//'curtis_gnu.out', recl=1024) -! write(2,'(a)') -! @ ' curtis matrix: table with 1.e+7 * acf(n,r) ' -! write(2,114) 'n,r', ( i, i=nl,1,-5 ) -! do in=nl,1,-5 -! write(2,*) -! write(2,115) in, ( c(in,ir)*1.d7, ir=nl,1,-5 ) -! end do -! close(2) - - -! write (*,*) ' ' -! write (*,*) ' curtis.out has been created. ' -! write (*,*) ' ' - -! else - -! write (layercode,132) ilayer -! open (2, status='new', -! @ file=dircurtis//'curtis'//layercode//'.out') -! write(2,'(a)') -! @ ' curtis matrix: table with 1.e+7 * acf(n,r) ' -! write(2,116) ' layer x c(',layercode, -! @ ',x) c(x,', layercode,')' -! do in=nl,1,-1 -! if (c(ilayer,ilayer).ne.0.d0) then -! write(2,117) in, c(ilayer,in), c(in,ilayer), -! @ c(ilayer,in)/c(ilayer,ilayer), -! @ c(in,ilayer)/c(ilayer,ilayer) -! else -! write(2,118) in, c(ilayer,in), c(in,ilayer) -! end if -! end do -! close(2) -! write (*,*) ' ' -! write (*,*) dircurtis//'curtis'//layercode//'.out', -! @ ' has been created.' -! write (*,*) ' ' - -! end if - -! elseif(itblout.eq.0)then - -! continue - -! else - -! write (*,*) ' error from elimin: ', -! @ ' itblout should be 1 or 0; itblout= ',itblout -! stop - -! end if - - return - -112 format(10x,10(i3,9x)) -113 format(1x,i3,2x,9(1pe9.2,2x)) - -114 format(1x,a3, 11(8x,i3)) -115 format( 1x,i3, 2x, 11(1pe10.3)) -116 format( 1x,a17,a2,a18,a2,a1 ) -117 format( 3x,i3, 4(8x,1pe10.3) ) -118 format( 3x,i3, 2(8x,1pe10.3) ) -120 format( 1x,i3, 1x,i3, 2x, 11(1pe10.3)) - -132 format(i3) - -! cambio: los formatos 114, 115 , 117 y 118 -! cambio: al cambia nl de 51 a 140 hay que cambiar el formato i2-->i3 -! y ahora en vez de 11 capas de 5 en 5, hay 28 -! - end -c************************************************************************** - subroutine smooth_cf( c, cs, i, nl, w ) -c hace un smoothing de c(i,*), de la contribucion de todas las capas -c menos de la capa en cuestion, la i. -c opcion w (width): el tamanho de la ventana del smoothing. -c output values: cs -c************************************************************************** - - implicit none - - integer j,np,i,nl,w - real*8 c(nl), cs(nl) - - if(w.eq.0) then - do j=1,nl - cs(j)=c(j) - end do - - elseif(w.eq.3) then - -! write (*,*) 'smoothing w=3' - do j=1,i-4 - if(j.eq.1) then - cs(j)=c(j) - else - cs(j)=1/3.d0*(c(j-1)+c(j)+c(j+1)) - end if - end do - do j=i+4,nl-1 - if(j.eq.nl) then - cs(j)=c(j) - else - cs(j)=1/3.d0*(c(j-1)+c(j)+c(j+1)) - end if - end do - elseif(w.eq.5) then - -! type *,'smoothing w=5' - do j=3,i-4 - if(j.eq.1) then - cs(j)=c(j) - else - cs(j)=1/5.d0*(c(j-2)+c(j-1)+c(j)+c(j+1)+c(j+2)) - end if - end do - do j=i+4,nl-2 - if(j.eq.nl) then - cs(j)=c(j) - else - cs(j)=1/5.d0*(c(j-2)+c(j-1)+c(j)+c(j+1)+c(j+2)) - end if - end do - end if - return - end - - Index: trunk/LMDZ.MARS/libf/phymars/getk_V09.F =================================================================== --- trunk/LMDZ.MARS/libf/phymars/getk_V09.F (revision 496) +++ (revision ) @@ -1,819 +1,0 @@ -c*********************************************************************** - - subroutine getk (tt) - -c jan 98 malv version for mz1d. copied from solar10/getk.f -c jul 2011 malv+fgg adapted to LMD-MGCM -c*********************************************************************** - - implicit none - - include 'nltedefs.h' - include 'tcr_15um.h' - include 'nlte_data.h' - include 'nlte_rates.h' - -c arguments - real tt ! i. temperature - -!! local variables: - real*8 k1x, k7x,k7xa,k7xb - real*8 k3x, k3xaa,k3xac,k3xab,k3xbb,k3xba,k3xbc - real*8 k3xco2,k3xn2,k3xco, k6x,k6x1,k6x2 - real*8 k20x,k20xa,k20xb,k20xc - real*8 k19xca,k19xcb,k19xcc - real*8 k19xba,k19xbb,k19xbc - real*8 k19xaa,k19xab,k19xac - real*8 k21x,k21xa,k21xb,k21xc - real*8 anu, factor , k21xa_626 - real tt1,tt2, de - integer i - -c*********************************************************************** - -co2i(001) + n2 ---> co2i + n2(1) k1 (not considered in the model -c k1(i) i = 1 --- 626 -! 2 --- 636 -! 3 --- 628 -! 4 --- 627 - -! k1x = 5.d-13 * sqrt(300.d0/tt) -! do i=1,nisot -! k1(i) = k1x * rf1 -! k1p(i) = k1(i) * exp( -ee/tt *1.d0* (-nun2+nu(i,4)) ) -! end do - -co2(001) + co2i ---> co2 + co2i(001) k2 (vv1 in table 4, paper i) -c k2i i = x --- 628 -! y --- 636 -! z --- 627 - - k2a = 6.8d-12 * sqrt(tt) ! delta(e)< 42 cm-1 - k2b = 3.6d-11 * sqrt(tt) * exp(-65.6557/26.3) ! > 42 cm-1 see table 3 - k2a = k2a * rf2desac - k2b = k2b * rf2desac - - k2x = 6.8d-12 * sqrt(tt) - k2y = 3.6d-11 * sqrt(tt) * exp(-65.6557/26.3) - k2z = 6.8d-12 * sqrt(tt) - k2x = k2x * rf2iso - k2y = k2y * rf2iso - k2z = k2z * rf2iso - k2xp = k2x * exp( dble( -ee/tt * (nu(1,4)-nu(2,4)) ) ) - k2yp = k2y * exp( dble( -ee/tt * (nu(1,4)-nu(3,4)) ) ) - k2zp = k2z * exp( dble( -ee/tt * (nu(1,4)-nu(4,4)) ) ) - -! these are vt1 in table 3, paper i -co2i(001) + m ---> co2i(0v0) + m k3 -co2i(001) + o3p ---> co2i(0v0) + o3p k7 -c k3vm(i) m = a --- co2 v = a --- 3 i = 1,2,3,4 -! b --- n2,o2 b --- 2 -! c --- co -c k7v(i) v = a --- 3 i = 1,2,3,4 -! b --- 2 - - k7x = 2.0d-13*sqrt(tt/300.d0) - k7x = k7x * rf7 - - if (iopt3.eq.0) then - - k3x = 2.2d-15 + 1.14d-10 * exp( dble(-76.75/tt**(1.d0/3.d0)) ) - k3xaa = 3.0d-15 + 1.72d-10 * exp( dble(-76.75/tt**(1.d0/3.d0)) ) - k3xac = 2.2d-15 + 9.66d-11 * exp( dble(-76.75/tt**(1.d0/3.d0)) ) - k3x = k3x * rf3 - k3xaa = k3xaa * rf3 - k3xac = k3xac * rf3 - - tt1=220.0 !500.0 !220.0 - tt2=250.0 !250.0 - if(tt.le.tt1)then - k3xab = k3x - k3xbb = 0.d0 - k7xa=k7x - k7xb=0.d0 - else if(tt.gt.tt2)then - k3xab = 0.d0 - k3xbb = k3x - k7xa=0.d0 - k7xb=k7x - else - k3xab = k3x/30.d0*(tt2-tt) - k3xbb = k3x/30.d0*(tt-tt1) - k7xa=k7x/30.d0*(tt2-tt) - k7xb=k7x/30.d0*(tt-tt1) - end if - k3xba = k3xbb - k3xbc = k3xbb - - elseif (iopt3.gt.0) then ! bauer et. al., 1987 - - if (tt.ge.190. .and. tt.le.250.) then - factor = 0.9d0 + dble( (0.1-0.9)/(250.-190.) * (tt-190.) ) - elseif (tt.lt.190.) then - factor = 0.9d0 - elseif (tt.gt.250.) then - factor = 0.1d0 - end if - - k3xn2 = 2.2d-15 + 1.14d-10 * exp(dble( -76.75/tt**(1.d0/3.d0)) ) - k3xn2 = k3xn2 * rf3 - k3xab = k3xn2 * factor - k3xbb = k3xn2 * (1.-factor) - - k7xa = k7x * factor - k7xb = k7x * (1.-factor) - - if (iopt3.eq.1) then - - if (tt.le.148.8) then - k3xco2 = 13.8 - 0.1807 * (tt-140.) - elseif (tt.ge.148.8 .and. tt.le.159.6) then - k3xco2 = 12.21 - 0.1787 * (tt-148.8) - elseif (tt.ge.159.6 .and. tt.le.171.0) then - k3xco2 = 10.28 - 0.04035 * (tt-159.6) - elseif (tt.ge.171.0 .and. tt.le.186.4) then - k3xco2 = 9.82 - 0.027273 * (tt-171.0) - elseif (tt.ge.186.4 .and. tt.le.244.1) then - k3xco2 = 9.4 + 0.002253 * (tt-186.4) - elseif (tt.ge.244.1 .and. tt.le.300) then - k3xco2 = 9.53 + 0.02129 * (tt-244.1) - elseif (tt.ge.300 .and. tt.le.336.1) then - k3xco2 = 10.72 + 0.052632 * (tt-300) - elseif (tt.ge.336.1 .and. tt.le.397.0) then - k3xco2 = 12.62 + 0.0844 * (tt-336.1) - elseif (tt.ge.397.0 .and. tt.le.523.4) then - k3xco2 = 17.76 + 0.2615 * (tt-397.) - end if - k3xco2 = k3xco2 * 1.d-15 * rf3 - k3xaa = 0.82d0 * k3xco2 - k3xba = 0.18d0 * k3xco2 - - if (tt.le.163.) then - k3xco = 10.58 - 0.093 * (tt-140) - elseif (tt.ge.163. .and. tt.le.180.) then - k3xco = 8.44 - 0.05353 * (tt-163.) - elseif (tt.ge.180. .and. tt.le.196.) then - k3xco = 7.53 - 0.034375 * (tt-180.) - elseif (tt.ge.196. .and. tt.le.248.) then - k3xco = 6.98 - 0.0108 * (tt-196.) - elseif (tt.ge.248. .and. tt.le.301.) then - k3xco = 6.42 + 0.01415 * (tt-248.) - elseif (tt.ge.301. .and. tt.le.353.) then - k3xco = 7.17 + 0.02865 * (tt-301.) - end if - k3xac = k3xco * 1.d-15 * rf3 - k3xbc = 0.d0 - - elseif (iopt3.eq.2) then ! revision for the papers (feb 93) - - k3xco2 = 7.3d-14 * exp( -850.3/tt + 86523/tt**2.d0 ) - k3xco2 = k3xco2 * rf3 - k3xaa = 0.82d0 * k3xco2 - k3xba = 0.18d0 * k3xco2 - - k3xco = 1.7d-14 * exp( -448.3/tt + 53636/tt**2.d0 ) - k3xac = k3xco * rf3 - k3xbc = 0.d0 - - end if - - end if - - do i=1,nisot - k3aa(i) = k3xaa - k3ba(i) = k3xba - k3ab(i) = k3xab - k3bb(i) = k3xbb - k3ac(i) = k3xac - k3bc(i) = k3xbc - anu = nu(i,4)-nu(i,3) -! anu = nu(i,4)-nu(i,3)+70 - k3aap(i) = k3aa(i) * exp( -ee/tt * anu )/6.d0 - k3abp(i) = k3ab(i) * exp( -ee/tt * anu )/6.d0 - k3acp(i) = k3ac(i) * exp( -ee/tt * anu )/6.d0 - anu = nu(i,4)-nu(i,2) -! anu = nu(i,4)-nu(i,2)+40 - k3bap(i) = k3ba(i) * exp( -ee/tt * anu )/4.d0 - k3bbp(i) = k3bb(i) * exp( -ee/tt * anu )/4.d0 - k3bcp(i) = k3bc(i) * exp( -ee/tt * anu )/4.d0 - - k7a(i) = k7xa - k7b(i) = k7xb - k7ap(i) = k7a(i) * exp(dble( -ee/tt*(nu(i,4)-nu(i,3)) ))/6.d0 - k7bp(i) = k7b(i) * exp(dble( -ee/tt*(nu(i,4)-nu(i,2)) ))/4.d0 - end do - - -! the next ones correspond to vv2 in table 4, paper i -co2i(001) + co2 ---> co2i(020) + co2(010) k6 -! k6(i) i = 1,2,3,4 -! we need a new index for the inverse rates due to both fractions : -c k6a(i) i=2,3,4 co2i(001) + co2 ---> co2i(020) + co2(010) -c k6b(i) " co2i(001) + co2 ---> co2i(010) + co2(020) - - if (iopt6.eq.1) then - - if(tt.le.175.d0)then - k6x=8.6d-15 - elseif(tt.gt.175.0.and.tt.le.200.d0)then - k6x=8.6d-15+9.d-16*(175.d0-tt)/25.d0 - elseif(tt.gt.200.0.and.tt.le.225.d0)then - k6x=7.7d-15+5.d-16*(200.d0-tt)/25.d0 - elseif(tt.gt.225.0.and.tt.le.250.d0)then - k6x=7.20d-15+6.d-16*(tt-225.d0)/25.d0 - elseif(tt.gt.250.0.and.tt.le.275.d0)then - k6x=7.80d-15+1.d-15*(tt-250.d0)/25.d0 - elseif(tt.gt.275.0.and.tt.le.300.d0)then - k6x=8.80d-15+1.3d-15*(tt-275.d0)/25.d0 - elseif(tt.gt.300.0.and.tt.le.325.d0)then - k6x=10.1d-15+1.54d-15*(tt-300.d0)/25.d0 - elseif(tt.gt.325.0)then - k6x=11.6d-15 - end if - - elseif (iopt6.eq.2) then - - k6x = 3.6d-13 * exp( -1660/tt + 176948/tt**2.d0 ) - if (tt.lt.175) k6x = 8.8d-15 - - end if - - k6x1 = k6x * rf6 * frac6 - k6x2 = k6x * rf6 * (1.-frac6) - - k6 = k6x * rf6 - k6p = k6 / 8.d0 * exp(dble( -ee/tt * (nu(1,4)-nu(1,2)-nu(1,1)) )) - do i=2,nisot - k6a(i) = k6x1 - k6b(i) = k6x2 - anu = nu(i,4)-nu(i,2)-nu(1,1) - k6ap(i) = k6a(i) / 8.d0 * exp(dble( -ee*anu/tt )) - anu = nu(i,4)-nu(i,1)-nu(1,2) - k6bp(i) = k6b(i) / 8.d0 * exp(dble( -ee*anu/tt )) - end do - - -co2i(0v0) + co2i ---> co2i(0v-10) + co2i(010) -c k5 esta reaccion es desdenable frente a co2 como colisionante. -! k5=3.0d-15+6.0d-17*(tt-210.d0) -! k5=k5*rf5 -! k5p=k5/2.d0*exp(-ee*125.77/tt) - - -co2i(0v0) + m ---> co2i(0v-10) + m k19 (vt2,k5,k6 in table 3, paper -co2i(0v0) + o3p ---> co2i(0v-10) + o3p k20 (vt2,k7 in table 3, paper -c k19vm(i) m = a --- co2 v = a --- 3 i=1,2,3,4 -! b --- n2 b --- 2 -! c --- co c --- 1 -c k20v(i) v = a --- 3 i = 1,2,3,4 -! b --- 2 -! c --- 1 -! -! k20x=1.9d-8*exp(-76.75/(tt**(1.d0/3.d0))) ! taylor,74 reajusted -! k20x=2.32d-9*exp(-76.75/(tt**(1./3.)))+1.0d-14*sqrt(tt) ! k&j, 83 -! k20x = 1.43d-12*(tt/300.d0) ! shved et al, 90 - - if (iopt20.eq.1) then ! first version of pap1 - k20x=2.32d-9*exp(-76.75/(tt**(1./3.)))+3.5d-13*sqrt(tt) ! s&w, 91 - k20xb = k20x / 2.d0 * rf20 - k20xc = k20xb - k20xa = 3.d0/2.d0 * k20xb - elseif(iopt20.eq.2) then ! revision for the papers in feb 93 - k20x=3.d-12 ! minimum value of lopez-puertas et al., 92 - k20xc = k20x * rf20 - k20xb = 2.d0 * k20xc - k20xa = 3.d0/2.d0 * k20xb - elseif(iopt20.eq.3) then ! values from boug & roble '91 - k20x=1.d-12/sqrt(300.) * sqrt(tt) - k20xc = k20x * rf20 - k20xb = 2.d0 * k20xc - k20xa = 3.d0/2.d0 * k20xb - elseif(iopt20.eq.4) then ! values from boug & dick '88 case b - k20x=7.d-13 - k20xc = k20x * rf20 - k20xb = 2.d0 * k20xc - k20xa = 3.d0/2.d0 * k20xb - elseif(iopt20.eq.5) then ! values from s.bougher (oct-98) - k20x = 1.732d-13 * sqrt(tt) ! 1/sqrt(300) * sqrt(t) - k20xc = k20x * rf20 - k20xb = 2.d0 * k20xc - k20xa = 3.d0/2.d0 * k20xb - end if - - if (iopt19.eq.0) then - - k19xca = 4.64d-10 * exp(dble( - 74.75 / tt**(1.d0/3.d0) )) - k19xcb = 6.69d-10 * exp(dble( - 84.07 / tt**(1.d0/3.d0) )) - k19xcc = k19xcb - - if ( tt.le.250 ) then - k19xba = 181.25d0 - elseif ( tt.ge.310 ) then - k19xba = 200.d0 + 0.9d0 * ( tt - 310.d0 ) - else - k19xba = 181.25d0 + 0.3125d0 * ( tt - 250.d0 ) - end if - k19xba = k19xba * 1.03558d-19 * tt ! cm-1 s-1 - k19xbb = 1.24d-14 * ( tt / 273.3d0 )**2.d0 ! taine & lepoutre 1979 - k19xbc = k19xbb - - k19xaa = 3.d0/2.d0 * k19xba - k19xab = 3.d0/2.d0 * k19xbb - k19xac = 3.d0/2.d0 * k19xbc - - k19xaa = k19xaa * rf19 - k19xab = k19xab * rf19 - k19xac = k19xac * rf19 - k19xba = k19xba * rf19 - k19xbb = k19xbb * rf19 - k19xbc = k19xbc * rf19 - k19xca = k19xca * rf19 - k19xcb = k19xcb * rf19 - k19xcc = k19xcc * rf19 - - elseif (iopt19.ge.1) then - - if (iopt19.eq.1) then ! lunt et. al., 1985 (thesis values) - - if (tt.le.175.) then - k19xca = 4.d0 - 0.02d0 * (tt-140.d0) - k19xcb = 0.494d0 + 0.0076 * (tt-140.d0) - elseif (tt.ge.175. .and. tt.le.200.) then - k19xca = 3.3d0 - 0.02d0 * (tt-175.) - k19xcb = 0.76d0 + 0.0076d0 * (tt-175.d0) - elseif (tt.ge.200. .and. tt.le.225.) then - k19xca = 2.8d0 + 0.004d0 * (tt-200.d0) - k19xcb = 0.95d0 + 0.014d0 * (tt-200.d0) - elseif (tt.ge.225. .and. tt.le.250.) then - k19xca = 2.9d0 + 0.024d0 * (tt-225.d0) - k19xcb = 1.3d0 + 0.016d0 * (tt-225.d0) - elseif (tt.ge.250. .and. tt.le.275.) then - k19xca = 3.5d0 + 0.04d0 * (tt-250.d0) - k19xcb = 1.7d0 + 0.032d0 * (tt-250.d0) - elseif (tt.ge.275. .and. tt.le.295.) then - k19xca = 4.5d0 + 0.055d0 * (tt-275.d0) - k19xcb = 2.5d0 + 0.045d0 * (tt-275.d0) - elseif (tt.ge.295. .and. tt.le.320.) then - k19xca = 5.6d0 + 0.54d0 * (tt-295.d0) - k19xcb = 3.4d0 + 0.045d0 * (tt-295.d0) - end if - k19xca = k19xca * 1.d-15 * rf19 - k19xcb = k19xcb * 1.d-15 * rf19 - k19xcc = k19xcb - - elseif (iopt19.eq.2) then ! revision for the papers, feb 1993 - -! k19xca = 7.3d-14 * exp( -850.3d0/tt + 86523.d0/tt**2.d0 ) - k19xca = 4.2d-12 * exp( -2988.d0/tt + 303930.d0/tt**2.d0 ) - if (tt.le.175.) k19xca = 3.3d-15 - k19xcb = 2.1d-12 * exp( -2659.d0/tt + 223052.d0/tt**2.d0 ) - if (tt.le.175.) k19xcb = 7.6d-16 - k19xca = k19xca * rf19 - k19xcb = k19xcb * rf19 - k19xcc = k19xcb - - elseif (iopt19.eq.3) then ! values from dick'72 for k19xc - ! k19xcb is not modified - if (tt.le.158.) then - k19xca = 0.724d-15 - elseif (tt.le.190.) then - k19xca = 0.724d-15 + - @ (1.1d-15-0.724d-15) * (tt-158.) / (190.-158.) - elseif (tt.le.250.) then - k19xca = 1.1d-15 + - @ (3.45d-15-1.1d-15) * (tt-190.) / (250.-190.) - elseif (tt.gt.250.) then - k19xca = 3.45d-15 - end if - k19xcb = 2.1d-12 * exp( -2659.d0/tt + 223052.d0/tt**2.d0 ) - if (tt.le.175.) k19xcb = 7.6d-16 - k19xca = k19xca * rf19 - k19xcb = k19xcb * rf19 - k19xcc = k19xcb - - elseif (iopt19.eq.5) then - - k19xca = 5.2d-15 ! s.bougher, nov-98 - k19xcb = 7.6d-16 ! nuestro, de feb-93 - k19xcc = k19xcb - - k19xca = k19xca * rf19 - k19xcb = k19xcb * rf19 - - end if - - factor = 2.5d0 - k19xba = factor * k19xca - k19xbb = factor * k19xcb - k19xbc = factor * k19xcc - factor = 3.d0/2.d0 - k19xaa = factor * k19xba - k19xab = factor * k19xbb - k19xac = factor * k19xbc - - end if - - do i = 1, nisot - - k19aa(i) = k19xaa - k19ba(i) = k19xba - k19ca(i) = k19xca - k19ab(i) = k19xab - k19bb(i) = k19xbb - k19cb(i) = k19xcb - k19ac(i) = k19xac - k19bc(i) = k19xbc - k19cc(i) = k19xcc - anu = nu(i,3)-nu(i,2) - k19aap(i) = k19aa(i) * 6.d0/4.d0 * exp(dble( -ee*anu/tt)) - k19abp(i) = k19ab(i) * 6.d0/4.d0 * exp(dble( -ee*anu/tt)) - k19acp(i) = k19ac(i) * 6.d0/4.d0 * exp(dble( -ee*anu/tt)) - anu = nu(i,2)-nu(i,1) - k19bap(i) = k19ba(i) * 2.d0 * exp(dble( -ee*anu/tt)) - k19bbp(i) = k19bb(i) * 2.d0 * exp(dble( -ee*anu/tt)) - k19bcp(i) = k19bc(i) * 2.d0 * exp(dble( -ee*anu/tt)) - anu = nu(i,1) - k19cap(i) = k19ca(i) * 2.d0 * exp(dble( -ee*anu/tt)) - k19cbp(i) = k19cb(i) * 2.d0 * exp(dble( -ee*anu/tt)) - k19ccp(i) = k19cc(i) * 2.d0 * exp(dble( -ee*anu/tt)) - - k20a(i) = k20xa - k20b(i) = k20xb - k20c(i) = k20xc - k20ap(i) = k20a(i)*6.d0/4.d0 * - @ exp(dble( -ee/tt * (nu(i,3)-nu(i,2)) )) - k20bp(i) = k20b(i)*4.d0/2.d0 * - @ exp(dble( -ee/tt * (nu(i,2)-nu(i,1)) )) - k20cp(i) = k20c(i)*2.d0/1.d0 * - @ exp(dble( -ee/tt * nu(i,1) )) - end do - -! write(1,*) tt,k19cap(1),k19ac(1) - -! the next ones correspond to vv3 in table 4 (paper i) -co2i(0v0) + co2 ---> co2i(0v-10) + co2(010) k21 also see k33 -c k21v(i) v = a --- 3 i = 1,2,3,4 -! b --- 2 -! c --- 1 -! we need a new index for the 030i rates due to both fractions : -c k21a1 co2i(030) + co2 ---> co2i(020) + co2(010) -c k21a2 co2i(030) + co2 ---> co2i(010) + co2(020) -co2i(010) + co2j(000) ---> co2i(000) + co2j(010) kijk21c see pag.22-s -! k23k21c i=628,j=636 -! k24k21c i=628,j=627 -! k34k21c i=636,j=627 - - if (iopt21.eq.0) then - k21x = 1.2d-11 - k21xb = k21x - k21xa = 3.d0/2.d0 * k21x - k21xc = k21x ! esta ultima no se usa con 626 - elseif (iopt21.eq.1) then - k21x = 2.49d-11 ! orr & smith, 1987 - k21xb = k21x - k21xa = 3.d0/2.d0 * k21xb ! oscilador armonico - k21xc = k21xb / 2.d0 ! novedad mia - elseif (iopt21.eq.2) then - k21x = 100.d0*k19xca ! dickinson'76 (icarus) - k21xb = k21x - k21xa = 3.d0/2.d0 * k21xb ! oscilador armonico - k21xc = k21xb / 2.d0 ! novedad mia - end if - k21xa_626 = k21xa * rf21a !* 0.01d0 !* 10.d0 - k21xa = k21xa * rf21a !* 0.01d0 - k21xb = k21xb * rf21b - k21xc = k21xc * rf21c - - k21a = k21xa_626 - k21ap = k21a * 6.d0/8.d0 * - @ exp( dble( -ee/tt * (nu(1,3)-nu(1,2)-nu(1,1)) ) ) - do i = 2, nisot - k21a1(i) = k21xa * frac21 - k21a2(i) = k21xa * (1.d0-frac21) - k21a1p(i) = k21a1(i) * 6.d0/8.d0 * - @ exp(dble( -ee/tt* (nu(i,3)-nu(i,2)-nu(1,1)) )) - k21a2p(i) = k21a2(i) * 6.d0/8.d0 * - @ exp(dble( -ee/tt* (nu(i,3)-nu(i,1)-nu(1,2)) )) - end do - - - do i = 1, nisot - k21b(i) = k21xb - k21c(i) = k21xc - k21bp(i) = k21b(i) * - @ exp(dble( -ee/tt* (nu(i,2)-nu(i,1)-nu(1,1)) )) - k21cp(i) = k21c(i) * - @ exp(dble( -ee/tt * (nu(i,1)-nu(1,1)) )) - end do - - k23k21c = k21xc - k24k21c = k21xc - k34k21c = k21xc - k23k21cp = k23k21c*2.d0/2.d0 * - @ exp(dble( -ee/tt* (nu(2,1)-nu(3,1)) )) - k24k21cp = k24k21c*2.d0/2.d0 * - @ exp(dble( -ee/tt* (nu(2,1)-nu(4,1)) )) - k34k21cp = k34k21c*2.d0/2.d0 * - @ exp(dble( -ee/tt* (nu(3,1)-nu(4,1)) )) - -!these are also vv3 in table 4, paper i -c k31 & k32 - - k31 = k21x * rf31 ! we're suposing thar the rate for the deactivation - ! v-v from high combinational levels is the same - k32 = k21x * rf32 ! that the one for : (020) --> (010) + (010) - -co2(***) + co2i ---> co2(***) + co2i(***) k33 -c k33a1 : co2(001) + co2i ---> co2(020) + co2i(010) (vv2, table 4, -! a2 : co2(001) + co2i ---> co2(010) + co2i(020) " -! b1 : co2(030) + co2i ---> co2(020) + co2i(010) (vv3, table 4, -! b2 : co2(030) + co2i ---> co2(010) + co2i(020) " -! c : co2(020) + co2i ---> co2(010) + co2i(010) " -! we have to add an index to the inverse rates, depending on the isotope - - k33c = k21x * rf33bc - k33b1 = 3.d0/3.d0 * k33c * frac33 - k33b2 = 3.d0/3.d0 * k33c * (1.d0-frac33) - k33a1 = k6x * rf33a * frac33 - k33a2 = k6x * rf33a * (1.d0-frac33) - - do i=2,nisot - k33a1p(i)=k33a1* - @ 1.d0/8.d0*exp(dble( -ee/tt* (nu(1,4)-nu(1,2)-nu(i,1)) )) - k33a2p(i)=k33a2* - @ 1.d0/8.d0*exp(dble( -ee/tt* (nu(1,4)-nu(1,1)-nu(i,2)) )) - k33b1p(i)=k33b1* - @ 6.d0/8.d0*exp(dble( -ee/tt* (nu(1,3)-nu(1,2)-nu(i,1)) )) - k33b2p(i)=k33b2* - @ 6.d0/8.d0*exp(dble( -ee/tt* (nu(1,4)-nu(1,1)-nu(i,2)) )) - k33cp(i) =k33c * exp(dble( -ee/tt * (nu(1,2)-nu(1,1)-nu(i,1)) )) - end do - -! here they are the vt3 in table 3, paper i -co2(2.7um) + m ---> co2(2.7um) + m k27 -c k27a : n8 + m ---> n6 + m -! b : n7 + m ---> n6 + m -! c : n8 + m ---> n7 + m - - if (iopt27.eq.0) then - k27a = 3.d-11 !between fermi levels - k27b = 3.d-13 !between side levels - k27c = 2.d0 * k27b !between side levels - elseif (iopt27.ge.1) then ! orr & smith, 1987 - k27a = 1.55d-12 - k27c = 4.97d-12 - k27b = k27c - end if - k27a = k27a * rf27f - k27b = k27b * rf27s - k27c = k27c * rf27s - - k27ap = k27a * exp(dble( -ee/tt * (nu(1,8)-nu(1,6)) )) - k27bp = k27b * exp(dble( -ee/tt * (nu(1,7)-nu(1,6)) )) - k27cp = k27c * exp(dble( -ee/tt * (nu(1,8)-nu(1,7)) )) - - -! the next two are not used in the model: - -c k28 : n* + n2 ---> n*low + n2(1) -! k28v v = a --- n8 -! b --- n7 -! c --- n6 -! k28a = 5.d-13 * sqrt(300.d0/tt) * rf28 ! = k1 -! k28b = k28a -! k28c = k28a -! k28ap = k28a * exp( -ee/tt * (nu(1,8)-1388.1847-nun2) ) -! k28bp = k28b * exp( -ee/tt * (nu(1,7)-1335.1317-nun2) ) -! k28cp = k28c * exp( -ee/tt * (nu(1,6)-1285.4087-nun2) ) - -c k29 : n* + co ---> n*low + co(1) -! k29v v = a --- n8 -! b --- n7 -! c --- n6 - -c k29a = ?????????? * rf29 -c k29b = k29a -c k29c = k29a - -c k29ap = k29a * exp( -ee/tt * (nu(1,8)-1388.1847-nuco) ) -c k29bp = k29b * exp( -ee/tt * (nu(1,7)-1335.1317-nuco) ) -c k29cp = k29c * exp( -ee/tt * (nu(1,6)-1285.4087-nuco) ) - - -! these are also vv1 processes in table 4, paper i -c k26 : -! 1. deactivation of the 626 isotope: -! reaction: n* + co2i ---> n*low + co2i(001) ; i=1-4 -! nomenclature: k26v ; v=a,b,c,d for n8,n7,n6,n5 respectively -! inverse rates: k26vp(i) ; i=1-4 -! 2. deactivation of the minor isotopes: -! reaction: n*_i + co2j ---> n*_i_low + (001)_j ; i=2-4 ; j=1-4 -! nomenclature: k26vij ; v=a,c,d for n8,n6,n5 respectively -! inverse rates: k26vijp -! 3. notes: -! a * it is clear that : k26vij=/=k26vjip, -! b * at the moment we do not include inverse rates for the case 2., o -! the deactivation of the main isotope (pg. 32b, sn1). -! c * not 0221 level for minor isotopes is considered. -! d * only a value is known for these rates, so all of the deactivatio -! the same, but not the inverse rates. -! e * although all the direct deactivation constants have the same val -! it is useful to distinguish between them with the present nam - - k26a = 6.8d-12 * sqrt(tt) * rf26 ! = k2 - k26b = k26a - k26c = k26a - if (iopt26.eq.0 .or. iopt26.eq.2) then - k26d = k26a - elseif( iopt26.eq.1) then - k26d = 1.15d-10 * rf26 - end if - - do i=1,4 - k26ap(i) = k26a * - @ exp(dble( -ee/tt * (nu(1,8)-nu12_1000-nu(i,4)) )) - k26bp(i) = k26b * - @ exp(dble( -ee/tt * (nu(1,7)- nu(1,2) -nu(i,4)) )) - k26cp(i) = k26c * - @ exp(dble( -ee/tt * (nu(1,6)-nu12_0200-nu(i,4)) )) - k26dp(i) = k26d * - @ exp(dble( -ee/tt * (nu(1,5)- nu(1,1) -nu(i,4)) )) - end do - - k26a21 = k26a - k26c21 = k26c - k26d21 = k26d - k26a22 = k26a - k26c22 = k26c - k26d22 = k26d - k26a23 = k26a - k26c23 = k26c - k26d23 = k26d - k26a24 = k26a - k26c24 = k26c - k26d24 = k26d - - k26a31 = k26a - k26c31 = k26c - k26d31 = k26d - k26a32 = k26a - k26c32 = k26c - k26d32 = k26d - k26a33 = k26a - k26c33 = k26c - k26d33 = k26d - k26a34 = k26a - k26c34 = k26c - k26d34 = k26d - - k26a41 = k26a - k26c41 = k26c - k26d41 = k26d - k26a42 = k26a - k26c42 = k26c - k26d42 = k26d - k26a43 = k26a - k26c43 = k26c - k26d43 = k26d - k26a44 = k26a - k26c44 = k26c - k26d44 = k26d - -!! some examples of inverse rates, although not used at the moment -! k26a32p = k26a32 * exp( -ee* (nu(3,8)-nu32_1000-nu(2,4)) / tt )*1./1. -! k26c32p = k26c32 * exp( -ee* (nu(3,6)-nu32_0200-nu(2,4)) / tt )*1./1. -! k26d32p = k26d32 * exp( -ee* (nu(3,5)- nu(3,1) -nu(2,4)) / tt )*2./2. -! -! k26a43 = k26a34 * exp( -ee* (nu(3,8)-nu32_1000-nu(4,4)) / tt )*1./1. -! k26c43 = k26c34 * exp( -ee* (nu(3,6)-nu32_0200-nu(4,4)) / tt )*1./1. -! k26d43 = k26d34 * exp( -ee* (nu(3,5)- nu(3,1) -nu(4,4)) / tt )*2./2. -! -! k26a24p = k26a24 * exp( -ee* (nu(2,8)-nu22_1000-nu(4,4)) / tt )*1./1. -! k26c24p = k26c24 * exp( -ee* (nu(2,6)-nu22_0200-nu(4,4)) / tt )*1./1. -! k26d24p = k26d24 * exp( -ee* (nu(2,5)- nu(2,1) -nu(4,4)) / tt )*2./2. - - -! this is taken as vv4 in table 4, paper i (in the inverse direction) -c k41 : co(v) + co2 ---> co(v-1) + co2(001) + de -! k41_v v=1,2,3,4 -! -! de = -205.9 cm-1 when v=1 -! de = -232.9 cm-1 when v=2 -! de = -258.6 cm-1 when v=3 -! de = -285.0 cm-1 when v=4 - - k41p_taylor = 1.56d-11 * exp( -30.12/tt**0.333333 )! [ s-1 cm+3 ] - k41p_shved = 7.5d7/sqrt(tt) ! [ s-1 atm-1 ] - k41p_shved = k41p_shved * 1.38d-16/1013250. * tt! [ s-1 cm+3 ] - k41p_starr_hannock = 6.27d3 ! [ s-1 torr-1 ] - - if (iopt41.eq.1) then - k41p_1 = k41p_starr_hannock * - @ 760.*1.38d-16/1013250. * tt ! [ s-1 cm+3 ] - elseif (iopt41.eq.2) then - k41p_1 = 1.6d-12 * exp( -1169/tt + 77601/tt**2.d0 ) - end if - k41p_1 = k41p_1 * rf41 - k41_1 = k41p_1 * exp(dble( -ee * 205.9/tt )) - k41_2 = k41_1 - k41p_2 = k41_2 * exp(dble( -ee * (-232.9)/tt )) - k41_3 = k41_1 - k41p_3 = k41_3 * exp(dble( -ee * (-258.6)/tt )) - k41_4 = k41_1 - k41p_4 = k41_4 * exp(dble( -ee * (-285.0)/tt )) - - !k41p_1 = k41p_1 * 1.d-6 - !k41p_2 = k41p_2 * 1.d-6 - -c k41iso : 63(v) + co2 ---> 63(v-1) + co2(001) + de -! k41iso_v v=1,2,3 -! de = -253 cm-1 when v=1 -! de = -278 cm-1 when v=2 -! de = -303 cm-1 when v=3 - - k41iso_1 = k41_1 - k41iso_1p = k41iso_1 * exp(dble( -ee * (-253.)/tt )) - k41iso_2 = k41iso_1 - k41iso_2p = k41iso_2 * exp(dble( -ee * (-278.)/tt )) - k41iso_3 = k41iso_1 - k41iso_3p = k41iso_3 * exp(dble( -ee * (-303.)/tt )) - - - -c k42 : co(v) + co ---> co(v-1) + co(1) + de=-26.481 si v=2 K42 -! -52.8940 si v=3 k42b -! -79.2402 si v=4 k42c -! tomado de stepanova & shved (ellos de powell, 1975), ver pg .. l5 - ! solo para v=2 : - - k42 = 2.89d-10 * (1./sqrt(tt) + 67.4/tt**1.5) * - @ exp(dble(24.78/tt)) - k42 = k42 * rf42 - k42b = k42 - k42c = k42 - k42p = k42 * exp(dble( -ee * (-26.481)/tt )) - k42bp = k42b * exp(dble( -ee * (-52.894)/tt )) - k42cp = k42c * exp(dble( -ee * (-79.24)/tt )) - -c k42iso : 63(v) + 63 ---> 63(v-1) + 63(1) + de=-25.31 si v=2 K42iso -! -50.57 si v=3 k42isob -! tomado de stepanova & shved (ellos de powell, 1975), ver pg .. l5 - ! solo para v=2 : - - k42iso = k42 - k42isop = k42iso * exp(dble( -ee * (-25.31)/tt )) - k42isob = k42 - k42isobp = k42isob * exp(dble( -ee * (-50.57)/tt )) - - -c k43 : co(v) + o3p ---> co(v-1) + o3p + de=2143 -! tomado de lewittes et. al, 1978 para v=1 - - if (iopt43.eq.1) then - tt1 = tt - 300. - k43 = 2.85d-14 * exp( dble( 9.5e-3*tt1 + 1.11e-4*tt1**2. ) ) - elseif (iopt43.eq.2) then - k43 = 1.4d-5 * exp( -10957.d0 / tt + 1.486d6 / tt**2.d0 ) - if ( tt.lt.265.0 ) k43 = 2.3d-14 - end if - k43 = k43 * rf43 - k43p = k43 * exp( -ee * dble(2143.3 / tt) ) - -c k43iso : co63(v) + o3p ---> co63(v-1) + o3p + de=2096 -! Por similitud con el anterior - - k43iso = k43 - k43isop = k43iso * exp( -ee * dble(2096. / tt) ) - - -c k44 : co62(v) + co63 ---> co62(v-1) + co63(1) + de -! basado en Lopez-Valverde et al para el caso v=1, solo usamos este -! k44x x = a --- v=1 de= 147.33 -! b --- v=2 de= 20.7241 -! c --- v=3 de= -5.7 -! d --- v=4 de= -32.0361 - - k44a = 2.0d-12 * rf44 ! Solo vamos a usar este, no los b,c,d - k44b = k44a - k44c = k44a - k44d = k44a - - de = 147.33 - k44ap = k44a * exp(dble( -ee * de/tt )) - de = 20.7241 - k44bp = k44b * exp(dble( -ee * de/tt )) - de = -5.7 - k44cp = k44c * exp(dble( -ee * de/tt )) - de = -32.0361 - k44dp = k44d * exp(dble( -ee * de/tt )) - - -co2(hcl) + co2 --> co2 + co2 + de(hcl) -! este rate tambien lo usamos para los high combination levels (para tra -! al lte. cualquier valor vale, supongo. es k_vthcl - - k_vthcl = 3.3d-15 ! similar al valor pequenho del vt2 - k_vthcl = k_vthcl * rf_hcl - - return - end Index: trunk/LMDZ.MARS/libf/phymars/hrkday_convert.F =================================================================== --- trunk/LMDZ.MARS/libf/phymars/hrkday_convert.F (revision 496) +++ (revision ) @@ -1,31 +1,0 @@ -c*********************************************************************** -c hrkday_convert.f -c -c fortran function that returns the factor for conversion from -c hr' [erg s-1 cm-3] to hr [ k day-1 ] -c -c mar 2010 fgg adapted to GCM -c jan 99 malv add o2 as major component. -c ago 98 malv also returns cp_avg,pm_avg -c jul 98 malv first version. -c*********************************************************************** - - function hrkday_convert - @ ( mmean_nlte,cpmean_nlte ) - - implicit none - - include 'comcstfi.h' - include 'param.h' - -c argumentos - real mmean_nlte,cpmean_nlte - real hrkday_convert - -ccccccccccccccccccccccccccccccccccccc - - hrkday_convert = daysec * n_avog / ( cpmean_nlte * 1.e4 * mmean_nlte ) - -c end - return - end Index: trunk/LMDZ.MARS/libf/phymars/interdp.F =================================================================== --- trunk/LMDZ.MARS/libf/phymars/interdp.F (revision 496) +++ (revision ) @@ -1,67 +1,0 @@ -c *********************************************************************** - subroutine interdp(yy,zz,m,y,z,n,opt) -c interpolation soubroutine. input values: y(n) at z(n). -c output values: yy(m) at zz(m). options: 1 -> lineal; 2 -> logarithmic -c jul 2011: malv+fgg Adapted to LMD-MGCM -c *********************************************************************** - implicit none - integer n,m,i,j,opt - real*8 zz(m),yy(m),z(n),y(n), zmin,zzmin,zmax,zzmax - -! write (*,*) ' d interpolating ' - call mindp (z,n,zmin) - call mindp (zz,m,zzmin) - call maxdp (z,n,zmax) - call maxdp (zz,m,zzmax) - - if(zzmin.lt.zmin)then - write (*,*) 'from d interp: new variable out of limits' - write (*,*) zzmin,'must be .ge. ',zmin - stop -! elseif(zzmax.gt.zmax)then -! write (*,*) 'from interp: new variable out of limits' -! write (*,*) zzmax, 'must be .le. ',zmax -! stop - end if - - do 1,i=1,m - - do 2,j=1,n-1 - if(zz(i).ge.z(j).and.zz(i).lt.z(j+1)) goto 3 - 2 continue -c in this case (zz(m).eq.z(n)) and j leaves the loop with j=n-1+1=n - if(opt.eq.1)then - yy(i)=y(n-1)+(y(n)-y(n-1))*(zz(i)-z(n-1))/(z(n)-z(n-1)) - elseif(opt.eq.2)then - if(y(n).eq.0.0d0.or.y(n-1).eq.0.0d0)then - yy(i)=0.0d0 - else - yy(i)=dexp(dlog(y(n-1))+dlog(y(n)/y(n-1))* - @ (zz(i)-z(n-1))/(z(n)-z(n-1))) - end if - else - write (*,*) - @ ' from d interp error: opt must be 1 or 2, opt= ',opt - end if - goto 1 - 3 continue - if(opt.eq.1)then - yy(i)=y(j)+(y(j+1)-y(j))*(zz(i)-z(j))/(z(j+1)-z(j)) -! write (*,*) ' ' -! write (*,*) ' z(j),z(j+1) =', z(j),z(j+1) -! write (*,*) ' t(j),t(j+1) =', y(j),y(j+1) -! write (*,*) ' zz, tt = ', zz(i), yy(i) - elseif(opt.eq.2)then - if(y(j+1).eq.0.0d0.or.y(j).eq.0.0d0)then - yy(i)=0.0d0 - else - yy(i)=dexp(dlog(y(j))+dlog(y(j+1)/y(j))* - @ (zz(i)-z(j))/(z(j+1)-z(j))) - end if - else - write (*,*) ' from interp error: opt must be 1 or 2, opt= ', - @ opt - end if - 1 continue - return - end Index: trunk/LMDZ.MARS/libf/phymars/interdp_limits.F =================================================================== --- trunk/LMDZ.MARS/libf/phymars/interdp_limits.F (revision 496) +++ (revision ) @@ -1,96 +1,0 @@ -c *********************************************************************** - - subroutine interdp_limits ( yy,zz,m, i1,i2, y,z,n, j1,j2, opt) - -c Interpolation soubroutine. -c Returns values between indexes i1 & i2, donde 1 =< i1 =< i2 =< m -c Solo usan los indices de los inputs entre j1,j2, 1 =< j1 =< j2 =< n -c Input values: y(n) , z(n) (solo se usan los valores entre j1,j2) -c zz(m) (solo se necesita entre i1,i2) -c Output values: yy(m) (solo se calculan entre i1,i2) -c Options: opt=1 -> lineal ,, opt=2 -> logarithmic -c Difference with interdp: -c here interpolation proceeds between indexes i1,i2 only -c if i1=1 & i2=m, both subroutines are exactly the same -c thus previous calls to interdp or interdp2 could be easily replaced - -c JAN 98 MALV Version for mz1d -c jul 2011 malv+fgg Adapted to LMD-MGCM -c *********************************************************************** - - implicit none - -! Arguments - integer n,m ! I. Dimensions - integer i1, i2, j1, j2, opt ! I - real*8 zz(m),yy(m) ! O - real*8 z(n),y(n) ! I - -! Local variables - integer i,j - real*8 zmin,zzmin,zmax,zzmax - -c ******************************* - -! type *, ' d interpolating ' - call mindp_limits (z,n,zmin, j1,j2) - call mindp_limits (zz,m,zzmin, i1,i2) - call maxdp_limits (z,n,zmax, j1,j2) - call maxdp_limits (zz,m,zzmax, i1,i2) - - if(zzmin.lt.zmin)then - write (*,*) 'from d interp: new variable out of limits' - write (*,*) zzmin,'must be .ge. ',zmin - stop -! elseif(zzmax.gt.zmax)then -! type *,'from interp: new variable out of limits' -! type *,zzmax, 'must be .le. ',zmax -! stop - end if - - do 1,i=i1,i2 - - do 2,j=j1,j2-1 - if(zz(i).ge.z(j).and.zz(i).lt.z(j+1)) goto 3 - 2 continue -c in this case (zz(i2).eq.z(j2)) and j leaves the loop with j=j2-1+1=j2 - if(opt.eq.1)then - yy(i)=y(j2-1)+(y(j2)-y(j2-1))*(zz(i)-z(j2-1))/(z(j2)-z(j2-1)) - elseif(opt.eq.2)then - if(y(j2).eq.0.0d0.or.y(j2-1).eq.0.0d0)then - yy(i)=0.0d0 - else - yy(i)=exp(log(y(j2-1))+log(y(j2)/y(j2-1))* - @ (zz(i)-z(j2-1))/(z(j2)-z(j2-1))) - end if - else - write (*,*) ' d interp : opt must be 1 or 2, opt= ',opt - end if - goto 1 - 3 continue - if(opt.eq.1)then - yy(i)=y(j)+(y(j+1)-y(j))*(zz(i)-z(j))/(z(j+1)-z(j)) -! type *, ' ' -! type *, ' z(j),z(j+1) =', z(j),z(j+1) -! type *, ' t(j),t(j+1) =', y(j),y(j+1) -! type *, ' zz, tt = ', zz(i), yy(i) - elseif(opt.eq.2)then - if(y(j+1).eq.0.0d0.or.y(j).eq.0.0d0)then - yy(i)=0.0d0 - else - yy(i)=exp(log(y(j))+log(y(j+1)/y(j))* - @ (zz(i)-z(j))/(z(j+1)-z(j))) - end if - else - write (*,*) ' interp : opt must be 1 or 2, opt= ',opt - end if - 1 continue - return - end - - - - - - - Index: trunk/LMDZ.MARS/libf/phymars/intersp.F =================================================================== --- trunk/LMDZ.MARS/libf/phymars/intersp.F (revision 496) +++ (revision ) @@ -1,68 +1,0 @@ -c *********************************************************************** - subroutine intersp(yy,zz,m,y,z,n,opt) -c interpolation soubroutine. input values: y(n) at z(n). -c output values: yy(m) at zz(m). options: 1 -> lineal; 2 -> logarithmic - -c jul 2011 malv+fgg -c *********************************************************************** - - implicit none - - integer n,m,i,j,opt - real zz(m),yy(m),z(n),y(n) - real zmin,zzmin,zmax,zzmax - -! write(*,*) ' interpolating' - call minsp(z,n,zmin) - call minsp(zz,m,zzmin) - call maxsp(z,n,zmax) - call maxsp(zz,m,zzmax) - - if(zzmin.lt.zmin)then - write(*,*) 'from interp: new variable out of limits' - write(*,*) zzmin,'must be .ge. ',zmin - stop -! elseif(zzmax.gt.zmax)then -! write(*,*)'from interp: new variable out of limits' -! write(*,*)zzmax, 'must be .le. ',zmax -! stop - end if - - do 1,i=1,m - - do 2,j=1,n-1 - if(zz(i).ge.z(j).and.zz(i).lt.z(j+1)) goto 3 - 2 continue -c in this case (zz(m).ge.z(n)) and j leaves the loop with j=n-1+1=n - if(opt.eq.1)then - yy(i)=y(n-1)+(y(n)-y(n-1))*(zz(i)-z(n-1))/(z(n)-z(n-1)) - elseif(opt.eq.2)then - if(y(n).eq.0.0.or.y(n-1).eq.0.0)then - yy(i)=0.0 - else - yy(i)=exp(log(y(n-1))+log(y(n)/y(n-1))* - @ (zz(i)-z(n-1))/(z(n)-z(n-1))) - end if - else - write(*,*)' from interp error: opt must be 1 or 2, opt= ',opt - end if - goto 1 - 3 continue - if(opt.eq.1)then - yy(i)=y(j)+(y(j+1)-y(j))*(zz(i)-z(j))/(z(j+1)-z(j)) - elseif(opt.eq.2)then - if(y(j+1).eq.0.0.or.y(j).eq.0.0)then - yy(i)=0.0 - else - yy(i)=exp(log(y(j))+log(y(j+1)/y(j))* - @ (zz(i)-z(j))/(z(j+1)-z(j))) - end if - else - write(*,*)' from interp error: opt must be 1 or 2, opt= ',opt - end if - 1 continue - - return - end - - Index: trunk/LMDZ.MARS/libf/phymars/invdiag.F =================================================================== --- trunk/LMDZ.MARS/libf/phymars/invdiag.F (revision 496) +++ (revision ) @@ -1,27 +1,0 @@ -c *********************************************************************** - subroutine invdiag(a,b,n) -c inverse of a diagonal matrix -c jul 2011 malv -c *********************************************************************** - implicit none - - integer n,i,j,k - real*8 a(n,n),b(n,n) - - do 1,i=2,n-1 - do 2,j=2,n-1 - if (i.eq.j) then - a(i,j) = 1.d0/b(i,i) - else - a(i,j)=0.0d0 - end if - 2 continue - 1 continue - do k=1,n - a(n,k) = 0.0d0 - a(1,k) = 0.0d0 - a(k,1) = 0.0d0 - a(k,n) = 0.0d0 - end do - return - end Index: trunk/LMDZ.MARS/libf/phymars/leetvt.F =================================================================== --- trunk/LMDZ.MARS/libf/phymars/leetvt.F (revision 496) +++ (revision ) @@ -1,47 +1,0 @@ -c*********************************************************************** - subroutine leetvt - -c reads input vibr. temps. from external files or sets lte values -c according to the driver table - -c jul 2011 malv+fgg adapted to LMD-MGCM -c malv Jan 07 Add new vertical fine-grid for NLTE -c jan 98 malv based on solar10sub -c*********************************************************************** - - implicit none - - include 'nltedefs.h' - include 'nlte_atm.h' - include 'nlte_results.h' - -c local variables - integer i - real*8 zld(nl), zyd(nzy) - real*8 xvt11(nzy), xvt21(nzy), xvt31(nzy), xvt41(nzy) - -c*********************************************************************** - - do i=1,nzy - zyd(i) = dble(zy(i)) - xvt11(i)= dble( ty(i) ) - xvt21(i)= dble( ty(i) ) - xvt31(i)= dble( ty(i) ) - xvt41(i)= dble( ty(i) ) - end do - - -c interpolate to the nlte subgrid - - do i=1,nl - zld(i) = dble( zl(i) ) - enddo - call interdp ( v626t1,zld,nl, xvt11,zyd,nzy, 1) - call interdp ( v628t1,zld,nl, xvt21,zyd,nzy, 1) - call interdp ( v636t1,zld,nl, xvt31,zyd,nzy, 1) - call interdp ( v627t1,zld,nl, xvt41,zyd,nzy, 1) - - -c end - return - end Index: trunk/LMDZ.MARS/libf/phymars/lubksb_dp.F =================================================================== --- trunk/LMDZ.MARS/libf/phymars/lubksb_dp.F (revision 496) +++ (revision ) @@ -1,38 +1,0 @@ - subroutine lubksb_dp(a,n,np,indx,b) - -c jul 2011 malv+fgg - - implicit none - - integer n,np - real*8 a(np,np),b(n) - integer indx(n) - - real*8 sum - integer ii, ll, i, j - - ii=0 - do 12 i=1,n - ll=indx(i) - sum=b(ll) - b(ll)=b(i) - if (ii.ne.0)then - do 11 j=ii,i-1 - sum=sum-a(i,j)*b(j) -11 continue - else if (sum.ne.0.0) then - ii=i - endif - b(i)=sum -12 continue - do 14 i=n,1,-1 - sum=b(i) - if(i.lt.n)then - do 13 j=i+1,n - sum=sum-a(i,j)*b(j) -13 continue - endif - b(i)=sum/a(i,i) -14 continue - return - end Index: trunk/LMDZ.MARS/libf/phymars/ludcmp_dp.F =================================================================== --- trunk/LMDZ.MARS/libf/phymars/ludcmp_dp.F (revision 496) +++ (revision ) @@ -1,73 +1,0 @@ - subroutine ludcmp_dp(a,n,np,indx,d) - -c jul 2011 malv+fgg - - implicit none - - integer n, np - real*8 a(np,np), d - integer indx(n) - - integer nmax, i, j, k, imax - real*8 tiny - parameter (nmax=100,tiny=1.0d-20) - real*8 vv(nmax), aamax, sum, dum - - - d=1.0d0 - do 12 i=1,n - aamax=0.0d0 - do 11 j=1,n - if (abs(a(i,j)).gt.aamax) aamax=abs(a(i,j)) -11 continue - if (aamax.eq.0.0) pause 'singular matrix.' - vv(i)=1.0d0/aamax -12 continue - do 19 j=1,n - if (j.gt.1) then - do 14 i=1,j-1 - sum=a(i,j) - if (i.gt.1)then - do 13 k=1,i-1 - sum=sum-a(i,k)*a(k,j) -13 continue - a(i,j)=sum - endif -14 continue - endif - aamax=0.0d0 - do 16 i=j,n - sum=a(i,j) - if (j.gt.1)then - do 15 k=1,j-1 - sum=sum-a(i,k)*a(k,j) -15 continue - a(i,j)=sum - endif - dum=vv(i)*abs(sum) - if (dum.ge.aamax) then - imax=i - aamax=dum - endif -16 continue - if (j.ne.imax)then - do 17 k=1,n - dum=a(imax,k) - a(imax,k)=a(j,k) - a(j,k)=dum -17 continue - d=-d - vv(imax)=vv(j) - endif - indx(j)=imax - if(j.ne.n)then - if(a(j,j).eq.0.0)a(j,j)=tiny - dum=1.0d0/a(j,j) - do 18 i=j+1,n - a(i,j)=a(i,j)*dum -18 continue - endif -19 continue - if(a(n,n).eq.0.0)a(n,n)=tiny - return - end Index: trunk/LMDZ.MARS/libf/phymars/mat_oper.F =================================================================== --- trunk/LMDZ.MARS/libf/phymars/mat_oper.F (revision 496) +++ (revision ) @@ -1,771 +1,0 @@ -c set of subroutines for the cz*.for programs: -! subroutine unit(a,n) -! subroutine vector(v,cte,n) -! subroutine diagop(a,v,n) -! subroutine diago(a,v,n) diagonal matrix with v -! subroutine dyago(a,v,n) diagonal matrix with inverse of v -! subroutine invdiag(a,b,n) inverse of diagonal matrix -! subroutine sypvvv(a,b,c,d,n) suma y prod de 3 vectores, muy comun -! subroutine sypvmv(v,w,b,u,n) suma y prod de 3 vectores, muy comun -! subroutine mulmvv(w,b,u,v,n) prod matriz vector vector -! subroutine muymvv(w,b,u,v,n) prod matriz (inv.vector) vector -! subroutine samem (a,m,n) -! subroutine samemcore (a,m,n,n-2) extract core of matrix -! subroutine samemsp (a,m,n) -! subroutine samevsp (v,w,n) -! subroutine samev (v,w,n) -! subroutine samevcore (v,w,n,n-2) extract core of vector -! no subroutine operaux (a,n, b,c,d,e, ll,mm,dd,maux1,maux2) -! no subroutine invmcore (a,acore,n, dd,ll,mm) -! subroutine mulmv(a,b,c,n) -! subroutine mulvmv(a,u,b,v,n) -! subroutine mulmm(a,b,c,n) -! subroutine summm(a,b,c,n) -! subroutine resmm(a,b,c,n) -! subroutine mulvv(a,b,c,n) -! subroutine sumvv(a,b,c,n) -! subroutine sumvvv(a,b,c,d,n) -! subroutine resvv(a,b,c,n) -! subroutine zerom(a,n) -! subroutine zeromsp (a,n) -! subroutine zero4m(a,b,c,d,n) -! subroutine zero4msp(a,b,c,d,n) -! subroutine zero3m(a,b,c,n) -! subroutine zero3msp(a,b,c,n) -! subroutine zero2m(a,b,n) -! subroutine zero2msp(a,b,n) -! subroutine zerov(a,n) -! subroutine zerovdim3(a,n1,n2,n3) ! sustituye a zerojt de cristina -! subroutine zero4v(a,b,c,d,n) -! subroutine zero3v(a,b,c,n) -! subroutine zero2v(a,b,n) -! subroutine zerovsp(a,n) -! subroutine zero4vsp(a,b,c,d,n) -! subroutine zero3vsp(a,b,c,n) -! subroutine zero2vsp(a,b,n) -! -! -! -! May-05 Sustituimos todos los zerojt de cristina por las subrutinas -! genericas zerov*** -! -c *********************************************************************** - subroutine unit(a,n) -c store the unit value in the diagonal of a -c *********************************************************************** - real*8 a(n,n) - integer n,i,j,k - do 1,i=2,n-1 - do 2,j=2,n-1 - if(i.eq.j) then - a(i,j) = 1.d0 - else - a(i,j)=0.0d0 - end if - 2 continue - 1 continue - do k=1,n - a(n,k) = 0.0d0 - a(1,k) = 0.0d0 - a(k,1) = 0.0d0 - a(k,n) = 0.0d0 - end do - return - end - -! subroutine vector(v,cte,n) -c *********************************************************************** - subroutine vector(v,cte,n) -c build a vector by storing the value cte in all its elements -c *********************************************************************** - real*8 v(n),cte - integer n,i - do 1,i=1,n - v(i) = cte - 1 continue - return - end -c *********************************************************************** - subroutine diagop(a,v,n) -c store the core of v in the diagonal elements of the square matrix a -c *********************************************************************** - real*8 a(n,n),v(n+2) - integer n,i,j,k - do 1,i=2,n-1 - do 2,j=2,n-1 - if(i.eq.j) then - a(i,j) = v(i+1) - else - a(i,j)=0.0d0 - end if - 2 continue - 1 continue - do k=1,n - a(n,k) = 0.0d0 - a(1,k) = 0.0d0 - a(k,1) = 0.0d0 - a(k,n) = 0.0d0 - end do - return - end -c *********************************************************************** - subroutine diago(a,v,n) -c store the vector v in the diagonal elements of the square matrix a -c *********************************************************************** - implicit none - - integer n,i,j,k - real*8 a(n,n),v(n) - - do 1,i=2,n-1 - do 2,j=2,n-1 - if(i.eq.j) then - a(i,j) = v(i) - else - a(i,j)=0.0d0 - end if - 2 continue - 1 continue - do k=1,n - a(n,k) = 0.0d0 - a(1,k) = 0.0d0 - a(k,1) = 0.0d0 - a(k,n) = 0.0d0 - end do - return - end -c *********************************************************************** - subroutine dyago(a,v,n) -c store the inverse of v in the diagonal elements of the square matrix a -c *********************************************************************** - implicit none - - integer n,i,j,k - real*8 a(n,n),v(n) - - do 1,i=2,n-1 - do 2,j=2,n-1 - if(i.eq.j) then - a(i,j) = 1.d0/v(i) - else - a(i,j)=0.0d0 - end if - 2 continue - 1 continue - do k=1,n - a(n,k) = 0.0d0 - a(1,k) = 0.0d0 - a(k,1) = 0.0d0 - a(k,n) = 0.0d0 - end do - return - end - -c *********************************************************************** - subroutine samem (a,m,n) -c store the matrix m in the matrix a -c *********************************************************************** - real*8 a(n,n),m(n,n) - integer n,i,j,k - do 1,i=2,n-1 - do 2,j=2,n-1 - a(i,j) = m(i,j) -2 continue -1 continue - do k=1,n - a(n,k) = 0.0d0 - a(1,k) = 0.0d0 - a(k,1) = 0.0d0 - a(k,n) = 0.0d0 - end do - return - end -c *********************************************************************** - subroutine samemcore (a,b,m,n) -c store the matrix m in the matrix a -c *********************************************************************** - real*8 a(m,m),b(n,n) - integer n,i,j,k - if ( m.ne.(n-2) ) stop 'Error in dimensions (m.ne.n-2) ' - do 1,i=2,n-1 - do 2,j=2,n-1 - a(i,j) = b(i,j) -2 continue -1 continue - return - end -c *********************************************************************** - subroutine samemsp (a,m,n) -c store the matrix m in the matrix a -c *********************************************************************** - real*4 a(n,n),m(n,n) - integer n,i,j,k - do 1,i=2,n-1 - do 2,j=2,n-1 - a(i,j) = m(i,j) -2 continue -1 continue - do k=1,n - a(n,k) = 0.0 - a(1,k) = 0.0 - a(k,1) = 0.0 - a(k,n) = 0.0 - end do - return - end -c *********************************************************************** - subroutine samevsp (v,w,n) -c store the vector w in the vector v -c *********************************************************************** - real*4 v(n),w(n) - integer n,i - do 1,i=2,n-1 - v(i) = w(i) - 1 continue - v(1) = 0.0 - v(n) = 0.0 - return - end -c *********************************************************************** - subroutine samev (v,w,n) -c store the vector w in the vector v -c *********************************************************************** - real*8 v(n),w(n) - integer n,i - do 1,i=2,n-1 - v(i) = w(i) - 1 continue - v(1) = 0.0d0 - v(n) = 0.0d0 - return - end -c *********************************************************************** - subroutine samevcore (v,w,m,n) -c store the vector w in the vector v -c *********************************************************************** - real*8 v(m),w(n) - integer n,i - if (m.ne.(n-2)) stop ' Error in dimensions (m.ne.n-2) ' - do 1,i=2,n-1 - v(i) = w(i) - 1 continue - return - end -!c *********************************************************************** -! subroutine operaux (a,n, b,c,d,e, ll,mm,dd,maux1,maux2) -!c *********************************************************************** -! real*8 a(n,n),b(n,n),c(n,n),d(n,n),e(n,n) -! real*8 maux1(n,n),maux2(n,n),ll(n),mm(n),dd -! integer n -! call mulmm(a,c,e,n) -! call unit(maux1,n) -! call resmm(maux2,maux1,a,n) ! maux2 = 1 - c e -! call mynvdpnd(maux2,n,dd,ll,mm) ! maux2 = 1 / (1-ce) -! call mulmm(a,c,d,n) -! call resmm(maux1,b,a,n) ! a = b - c d -! call mulmm(a,maux2,maux1,n) ! a = cax2 * (b-cd) -! return -! end -!c *********************************************************************** -! subroutine invmcore (a,acore,n, dd,ll,mm) -!c *********************************************************************** -! real*8 a(n,n), acore(n-2,n-2) -! real*8 ll(n-2),mm(n-2),dd -! integer i,n,j,k -! -! do i=2,n-1 -! do j=2,n-1 -! acore(i-1,j-1) = a(i,j) -! end do -! end do -! call mynvdpnd (acore,n-2,dd,ll,mm) -! do i=2,n-1 -! do j=2,n-1 -! a(i,j) = acore(i-1,j-1) -! end do -! end do -! do k=1,n -! a(1,k) = 0.d0 -! a(n,k) = 0.d0 -! a(k,1) = 0.d0 -! a(k,n) = 0.d0 -! end do -! -! return -! end -c *********************************************************************** - subroutine mulmv(a,b,c,n) -c do a(i)=b(i,j)*c(j). a, b, and c must be distint -c *********************************************************************** - implicit none - - integer n,i,j - real*8 a(n),b(n,n),c(n),sum - - do 1,i=2,n-1 - sum=0.0d0 - do 2,j=2,n-1 - sum=sum+ (b(i,j)) * (c(j)) - 2 continue - a(i)=sum - 1 continue - a(1) = 0.0d0 - a(n) = 0.0d0 - return - end - - - -cc *********************************************************************** - subroutine muymmv(w,b,c,v,n) -c c(i,j) is diagonall and will be inverted. Let us call Z(i)=c(i,i)^(-1) -c Z(i) and v(i) are vectors. multiply first Z(i) and v(i) -c them multiply b and the previous product. w(i)=b(i,j)*(Z(j)+v(j)) -c *********************************************************************** - real*8 w(n),b(n,n),c(n,n),v(n), sum - integer n,i,j,k - do 1,i=2,n-1 - sum=0.0d0 - do 2,j=2,n-1 - sum=sum+ (b(i,j)) * (v(j)/c(j,j)) - 2 continue - w(i)=sum - 1 continue - w(1) = 0.0d0 - w(n) = 0.0d0 - return - end -cc *********************************************************************** - subroutine muymvv(w,b,u,v,n) -c u(i) is to be inverted. Let us call Z=u^(-1) -c Z(i) and v(i) are vectors. multiply first Z(i) and v(i) -c them multiply b and the previous product. w(i)=b(i,j)*(Z(j)+v(j)) -c *********************************************************************** - real*8 w(n),u(n),b(n,n),v(n), sum - integer n,i,j,k - do 1,i=2,n-1 - sum=0.0d0 - do 2,j=2,n-1 - sum=sum+ (b(i,j)) * (v(j)/u(j)) - 2 continue - w(i)=sum - 1 continue - w(1) = 0.0d0 - w(n) = 0.0d0 - return - end -c *********************************************************************** - subroutine mulmvv(w,b,u,v,n) -c u(i) and v(i) are vectors. multiply first u(i) and v(i) -c them multiply b and the previous product. w(i)=b(i,j)*(u(j)+v(j)) -c *********************************************************************** - real*8 w(n),u(n),b(n,n),v(n), sum - integer n,i,j,k - do 1,i=2,n-1 - sum=0.0d0 - do 2,j=2,n-1 - sum=sum+ (b(i,j)) * (u(j)+v(j)) - 2 continue - w(i)=sum - 1 continue - w(1) = 0.0d0 - w(n) = 0.0d0 - return - end -c *********************************************************************** - subroutine mulvmv(a,u,b,v,n) -c u(i) and v(i) are vectors. store u(i) and v(i) in the diagonal -c elements of square matrixes. then do a(i,j)= u(i,i)*b(i,j)*v(j,j) -c *********************************************************************** - real*8 a(n,n),u(n),b(n,n),v(n) - integer n,i,j,k - do i=2,n-1 - do j=2,n-1 - a(i,j)=(b(i,j)) * (v(j)) - end do - end do - do i=2,n-1 - do j=2,n-1 - a(i,j)=(u(i)) * (a(i,j)) - end do - end do - do k=1,n - a(1,k) = 0.d0 - a(n,k) = 0.d0 - a(k,1) = 0.d0 - a(k,n) = 0.d0 - end do - - return - end -c *********************************************************************** - subroutine mulmm(a,b,c,n) -c *********************************************************************** - real*8 a(n,n), b(n,n), c(n,n) - integer n,i,j,k - -! do i=2,n-1 -! do j=2,n-1 -! a(i,j)= 0.d00 -! do k=2,n-1 -! a(i,j) = a(i,j) + b(i,k) * c(k,j) -! end do -! end do -! end do - do j=2,n-1 - do i=2,n-1 - a(i,j)=0.d0 - enddo - do k=2,n-1 - do i=2,n-1 - a(i,j)=a(i,j)+b(i,k)*c(k,j) - enddo - enddo - enddo - do k=1,n - a(n,k) = 0.0d0 - a(1,k) = 0.0d0 - a(k,1) = 0.0d0 - a(k,n) = 0.0d0 - end do - - return - end -c *********************************************************************** - subroutine summm(a,b,c,n) -c *********************************************************************** - real*8 a(n,n), b(n,n), c(n,n) - integer n,i,j,k - - do i=2,n-1 - do j=2,n-1 - a(i,j)= b(i,j) + c(i,j) - end do - end do - do k=1,n - a(n,k) = 0.0d0 - a(1,k) = 0.0d0 - a(k,1) = 0.0d0 - a(k,n) = 0.0d0 - end do - - return - end -c *********************************************************************** - subroutine resmm(a,b,c,n) -c *********************************************************************** - real*8 a(n,n), b(n,n), c(n,n) - integer n,i,j,k - - do i=2,n-1 - do j=2,n-1 - a(i,j)= b(i,j) - c(i,j) - end do - end do - do k=1,n - a(n,k) = 0.0d0 - a(1,k) = 0.0d0 - a(k,1) = 0.0d0 - a(k,n) = 0.0d0 - end do - - return - end -c *********************************************************************** - subroutine mulvv(a,b,c,n) -c a(i)=b(i)*c(i) -c *********************************************************************** - real*8 a(n),b(n),c(n) - integer n,i - do 1,i=2,n-1 - a(i)= (b(i)) * (c(i)) - 1 continue - a(1) = 0.0d0 - a(n) = 0.0d0 - return - end -c *********************************************************************** - subroutine sumvv(a,b,c,n) -c a(i)=b(i)+c(i) -c *********************************************************************** - implicit none - - integer n,i - real*8 a(n),b(n),c(n) - - do 1,i=2,n-1 - a(i)= (b(i)) + (c(i)) - 1 continue - a(1) = 0.0d0 - a(n) = 0.0d0 - return - end - -c *********************************************************************** - subroutine sumvvv(a,b,c,d,n) -c a(i)=b(i)+c(i)+d(i) -c *********************************************************************** - real*8 a(n),b(n),c(n),d(n) - integer n,i - do 1,i=2,n-1 - a(i)= b(i) + c(i) + d(i) - 1 continue - a(1) = 0.0d0 - a(n) = 0.0d0 - return - end -c *********************************************************************** - subroutine resvv(a,b,c,n) -c a(i)=b(i)-c(i) -c *********************************************************************** - real*8 a(n),b(n),c(n) - integer n,i - do 1,i=2,n-1 - a(i)= (b(i)) - (c(i)) - 1 continue - a(1) = 0.0d0 - a(n) = 0.0d0 - return - end -c *********************************************************************** - subroutine zerom(a,n) -c a(i,j)= 0.0 -c *********************************************************************** - - implicit none - - integer n,i,j - real*8 a(n,n) - - do 1,i=1,n - do 2,j=1,n - a(i,j) = 0.0d0 - 2 continue - 1 continue - return - end -c *********************************************************************** - subroutine zeromsp (a,n) -c a(i,j)= 0.0 -c *********************************************************************** - real*4 a(n,n) - integer n,i,j - do 1,i=1,n - do 2,j=1,n - a(i,j) = 0.0 - 2 continue - 1 continue - return - end -c *********************************************************************** - subroutine zero4m(a,b,c,d,n) -c a(i,j) = b(i,j) = c(i,j) = d(i,j) = 0.0 -c *********************************************************************** - real*8 a(n,n), b(n,n), c(n,n), d(n,n) - integer n,i,j - do 1,i=1,n - do 2,j=1,n - a(i,j) = 0.0d0 - b(i,j) = 0.0d0 - c(i,j) = 0.0d0 - d(i,j) = 0.0d0 - 2 continue - 1 continue - return - end -c *********************************************************************** - subroutine zero4msp(a,b,c,d,n) -c a(i,j) = b(i,j) = c(i,j) = d(i,j) = 0.0 -c *********************************************************************** - real*4 a(n,n), b(n,n), c(n,n), d(n,n) - integer n,i,j - do 1,i=1,n - do 2,j=1,n - a(i,j) = 0.0 - b(i,j) = 0.0 - c(i,j) = 0.0 - d(i,j) = 0.0 - 2 continue - 1 continue - return - end -c *********************************************************************** - subroutine zero3m(a,b,c,n) -c a(i,j) = b(i,j) = c(i,j) = 0.0 -c ********************************************************************** - real*8 a(n,n), b(n,n), c(n,n) - integer n,i,j - do 1,i=1,n - do 2,j=1,n - a(i,j) = 0.0d0 - b(i,j) = 0.0d0 - c(i,j) = 0.0d0 - 2 continue - 1 continue - return - end -c *********************************************************************** - subroutine zero3msp(a,b,c,n) -c a(i,j) = b(i,j) = c(i,j) = 0.0 -c *********************************************************************** - real*4 a(n,n), b(n,n), c(n,n) - integer n,i,j - do 1,i=1,n - do 2,j=1,n - a(i,j) = 0.0 - b(i,j) = 0.0 - c(i,j) = 0.0 - 2 continue - 1 continue - return - end -c *********************************************************************** - subroutine zero2m(a,b,n) -c a(i,j) = b(i,j) = 0.0 -c *********************************************************************** - real*8 a(n,n), b(n,n) - integer n,i,j - do 1,i=1,n - do 2,j=1,n - a(i,j) = 0.0d0 - b(i,j) = 0.0d0 - 2 continue - 1 continue - return - end -c *********************************************************************** - subroutine zero2msp(a,b,n) -c a(i,j) = b(i,j) = 0.0 -c *********************************************************************** - real*4 a(n,n), b(n,n) - integer n,i,j - do 1,i=1,n - do 2,j=1,n - a(i,j) = 0.0 - b(i,j) = 0.0 - 2 continue - 1 continue - return - end -c *********************************************************************** - subroutine zerov(a,n) -c a(i)= 0.0 -c *********************************************************************** - real*8 a(n) - integer n,i - do 1,i=1,n - a(i) = 0.0d0 - 1 continue - return - end -c *********************************************************************** - subroutine zero4v(a,b,c,d,n) -c a(i) = b(i) = c(i) = d(i,j) = 0.0 -c *********************************************************************** - real*8 a(n), b(n), c(n), d(n) - integer n,i - do 1,i=1,n - a(i) = 0.0d0 - b(i) = 0.0d0 - c(i) = 0.0d0 - d(i) = 0.0d0 - 1 continue - return - end -c *********************************************************************** - subroutine zero3v(a,b,c,n) -c a(i) = b(i) = c(i) = 0.0 -c *********************************************************************** - real*8 a(n), b(n), c(n) - integer n,i - do 1,i=1,n - a(i) = 0.0d0 - b(i) = 0.0d0 - c(i) = 0.0d0 - 1 continue - return - end -c *********************************************************************** - subroutine zero2v(a,b,n) -c a(i) = b(i) = 0.0 -c *********************************************************************** - real*8 a(n), b(n) - integer n,i - do 1,i=1,n - a(i) = 0.0d0 - b(i) = 0.0d0 - 1 continue - return - end -c *********************************************************************** - subroutine zerovsp(a,n) -c a(i)= 0.0 -c *********************************************************************** - real*4 a(n) - integer n,i - do 1,i=1,n - a(i) = 0.0 - 1 continue - return - end -c *********************************************************************** - subroutine zero4vsp(a,b,c,d,n) -c a(i) = b(i) = c(i) = d(i) = 0.0 -c *********************************************************************** - real*4 a(n), b(n), c(n), d(n) - integer n,i - do 1,i=1,n - a(i) = 0.0 - b(i) = 0.0 - c(i) = 0.0 - d(i) = 0.0 - 1 continue - return - end -c *********************************************************************** - subroutine zero3vsp(a,b,c,n) -c a(i) = b(i) = c(i) = 0.0 -c ********************************************************************** - real*4 a(n), b(n), c(n) - integer n,i - do 1,i=1,n - a(i) = 0.0 - b(i) = 0.0 - c(i) = 0.0 - 1 continue - return - end -c *********************************************************************** - subroutine zero2vsp(a,b,n) -c a(i) = b(i) = 0.0 -c *********************************************************************** - real*4 a(n), b(n) - integer n,i - do 1,i=1,n - a(i) = 0.0 - b(i) = 0.0 - 1 continue - return - end -c *********************************************************************** - !subroutine zerojt(a,n1,n2,n3) - subroutine zerovdim3(a,n1,n2,n3) ! sustituye a zerojt de cristina -c a(i,j,k)= 0.0 -c jt(icol,nisos,nb+1,n) -c *********************************************************************** -! real*4 a(9,34,n) -! integer n,i,j,k,icol,ic - real*4 a(n1,n2,n3) - integer n1,n2,n3,i,j,k - - do 2,i=1,n1 - do 3,j=1,n2 - do 4,k=1,n3 - a(i,j,k) = 0.0 - 4 continue - 3 continue - 2 continue - - return - end -c *********************************************************************** Index: trunk/LMDZ.MARS/libf/phymars/maxdp.F =================================================================== --- trunk/LMDZ.MARS/libf/phymars/maxdp.F (revision 496) +++ (revision ) @@ -1,17 +1,0 @@ -cccccccccccc -c subroutina para calcular el maximo de los valores de una variable a -c en dble precision - subroutine maxdp(a,n,ymax) -c jul 2011 malv+fgg -cccccccccccc - implicit none - integer n,i - real*8 a(n), ymax - - ymax = a(1) - do i=2,n - if (a(i).gt.ymax) ymax=a(i) - end do - - return - end Index: trunk/LMDZ.MARS/libf/phymars/maxdp_2.F =================================================================== --- trunk/LMDZ.MARS/libf/phymars/maxdp_2.F (revision 496) +++ (revision ) @@ -1,22 +1,0 @@ -c subroutina para calcular el maximo de los valores de una variable -c en double precision - subroutine maxdp_2(a,n,ymax,imax) -c -c jul 2011 malv+fgg - - implicit none - integer n, i, imax - real*8 a(n), y, ymax - - imax=0 - y=-1.7d+38 - do i=1,n - if(a(i).gt.y) then - y=a(i) - imax=i - end if - end do - ymax=y -! type *,'imax,ymax',imax,ymax - return - end Index: trunk/LMDZ.MARS/libf/phymars/maxdp_limits.F =================================================================== --- trunk/LMDZ.MARS/libf/phymars/maxdp_limits.F (revision 496) +++ (revision ) @@ -1,24 +1,0 @@ -cccccccccccccc -c subroutina para calcular el maximo de los valores de una variable -c de doble precision. Simlar a maxdp salvo la adicion de limites - - subroutine maxdp_limits ( a,n,ymax, n1,n2 ) - -c jul 2011 malv -cccccccccccccc - - implicit none - integer n, i, n1,n2 - real*8 a(n),ymax - - if ( n1 .gt. n2 ) stop 'MAXDP_LIMITS. Error: n1 > n2 ' - if ( n1 .lt. 1 ) stop 'MAXDP_LIMTIS. Error: n1 < 2 ' - if ( n2 .gt. n ) stop 'MAXDP_LIMITS. Error: n2 > n ' - - ymax=a(n1) - do i=n1+1,n2 ! Si n1=n2 este bucle no se ejecuta - if (a(i).gt.ymax) ymax=a(i) - end do - - return - end Index: trunk/LMDZ.MARS/libf/phymars/maxsp.F =================================================================== --- trunk/LMDZ.MARS/libf/phymars/maxsp.F (revision 496) +++ (revision ) @@ -1,14 +1,0 @@ -c subroutina para calcular el maximo de los valores de una variable -c en simple precision - -c jul 2011 malv+fgg - - subroutine maxsp(a,n,ymax) - real a(n) - - ymax=-1.0e+34 - do i=1,n - if(a(i).gt.ymax)ymax=a(i) - end do - return - end Index: trunk/LMDZ.MARS/libf/phymars/mindp.F =================================================================== --- trunk/LMDZ.MARS/libf/phymars/mindp.F (revision 496) +++ (revision ) @@ -1,17 +1,0 @@ -ccccccccccc -c subroutina para calcular el minimo de los valores de una variable -c de doble precision - subroutine mindp ( a,n,ymin ) -c jul 2011 malv+fgg -ccccccccccc - implicit none - integer n, i - real*8 a(n),ymin - - ymin=a(1) - do i=2,n - if (a(i).lt.ymin) ymin=a(i) - end do - - return - end Index: trunk/LMDZ.MARS/libf/phymars/mindp_limits.F =================================================================== --- trunk/LMDZ.MARS/libf/phymars/mindp_limits.F (revision 496) +++ (revision ) @@ -1,24 +1,0 @@ -cccccccccccccc -c subroutina para calcular el minimo de los valores de una variable -c de doble precision. Simlar a mindp salvo la adicion de limites - - subroutine mindp_limits ( a,n,ymin, n1,n2 ) - -c jul 2011 malv+fgg -cccccccccccccc - - implicit none - integer n, i, n1,n2 - real*8 a(n),ymin - - if ( n1 .gt. n2 ) stop 'MINDP_LIMITS. Error: n1 > n2 ' - if ( n1 .lt. 1 ) stop 'MINDP_LIMITS. Error: n1 < 2 ' - if ( n2 .gt. n ) stop 'MINDP_LIMITS. Error: n2 > n ' - - ymin=a(n1) - do i=n1+1,n2 - if (a(i).lt.ymin) ymin=a(i) - end do - - return - end Index: trunk/LMDZ.MARS/libf/phymars/minsp.F =================================================================== --- trunk/LMDZ.MARS/libf/phymars/minsp.F (revision 496) +++ (revision ) @@ -1,15 +1,0 @@ -c subroutina para calcular el minimo de los valores de una variable -c de simple precision - -c jul 2011 malv+fgg - - subroutine minsp(a,n,ymin) - real a(n) - - y=1.0d+34 - do i=1,n - if(a(i).lt.y)y=a(i) - end do - ymin=y - return - end Index: trunk/LMDZ.MARS/libf/phymars/mzcf.F =================================================================== --- trunk/LMDZ.MARS/libf/phymars/mzcf.F (revision 496) +++ (revision ) @@ -1,320 +1,0 @@ -c*********************************************************************** -c************************ [valverde.marte.mod2] mzcf.for *************** - - subroutine mzcf( tauinf,tau, c,cup,cdw,vc,taugr, - @ ib,isot,icfout,itableout ) - -c a.k.murphy method to avoid extrapolation in the curtis matrix -c feb-89 m. angel granada -c 25-sept-96 cristina dejar las matrices en doble precision -c jan 98 malv version para mz1d -c jul 2011 malv+fgg adapted to LMD-MGCM -c*********************************************************************** - - implicit none - - include 'comcstfi.h' - include 'nltedefs.h' - include 'nlte_atm.h' - include 'nlte_data.h' - include 'tcr_15um.h' - include 'nlte_curtis.h' - -c arguments - real*8 c(nl,nl), cup(nl,nl), cdw(nl,nl) ! o - real*8 vc(nl), taugr(nl) ! o - real*8 tau(nl,nl) ! i - real*8 tauinf(nl) ! i - integer ib ! i - integer isot ! i - integer icfout, itableout ! i - -c external - external bandid - character*2 bandid - -c local variables - integer i, in, ir, iw - real*8 cfup(nl,nl), cfdw(nl,nl) - real*8 a(nl,nl), cf(nl,nl) - character isotcode*2, bcode*2 - -c formats - 101 format(i1) - 202 format(i2) - 180 format(a80) - 181 format(a80) -c*********************************************************************** - - if (isot.eq.1) isotcode = '26' - if (isot.eq.2) isotcode = '28' - if (isot.eq.3) isotcode = '36' - if (isot.eq.4) isotcode = '27' - if (isot.eq.5) isotcode = 'co' - bcode = bandid( ib ) - -! write (*,*) ' ' - - do in=1,nl - - do ir=1,nl - - cf(in,ir) = 0.0d0 - cfup(in,ir) = 0.0d0 - cfdw(in,ir) = 0.0d0 - c(in,ir) = 0.0d0 - cup(in,ir) = 0.0d0 - cdw(in,ir) = 0.0d0 - a(in,ir) = 0.0d0 - - end do - - vc(in) = 0.0d0 - taugr(in) = 0.0d0 - - end do - - -c the next lines are a reduced and equivalent way of calculating -c the c(in,ir) elements for n=2,nl1 and r=1,nl - - -c do in=2,nl1 -c do ir=1,nl -c if(ir.eq.1)then -c c(in,ir)=tau(in-1,1)-tau(in+1,1) -c elseif(ir.eq.nl)then -c c(in,ir)=tau(in+1,nl1)-tauinf(in+1)-tau(in-1,nl1)+tauinf(in-1) -c else -c c(in,ir)=tau(in+1,ir-1)-tau(in+1,ir)-tau(in-1,ir-1)+tau(in-1,ir) -c end if -c c(in,ir)=c(in,ir)*pi*deltanu(ib)/(2.*deltaz*1.0e5) -c end do -c end do -c go to 1000 - -c calculation of the matrix cfup(nl,nl) - - cfup(1,1) = 1.d0 - tau(1,1) - - do in=2,nl - do ir=1,in - - if (ir.eq.1) then - cfup(in,ir) = tau(in,ir) - tau(in,1) - elseif (ir.eq.in) then - cfup(in,ir) = 1.d0 - tau(in,ir-1) - else - cfup(in,ir) = tau(in,ir) - tau(in,ir-1) - end if - - end do - end do - -! contribution to upwards fluxes from bb at bottom : - do in=1,nl - taugr(in) = tau(in,1) - enddo - -c calculation of the matrix cfdw(nl,nl) - - cfdw(nl,nl) = 1.d0 - tauinf(nl) - - do in=1,nl-1 - do ir=in,nl - - if (ir.eq.in) then - cfdw(in,ir) = 1.d0 - tau(in,ir) - elseif (ir.eq.nl) then - cfdw(in,ir) = tau(in,ir-1) - tauinf(in) - else - cfdw(in,ir) = tau(in,ir-1) - tau(in,ir) - end if - - end do - end do - - -c calculation of the matrix cf(nl,nl) - - do in=1,nl - do ir=1,nl - - if (ir.eq.1) then - ! version con l_bb(tg) = l_bb(t(1))=j(1) (see also vc below) - ! cf(in,ir) = tau(in,ir) - ! version con l_bb(tg) =/= l_bb(t(1))=j(1) (see also vc below) - cf(in,ir) = tau(in,ir) - tau(in,1) - elseif (ir.eq.nl) then - cf(in,ir) = tauinf(in) - tau(in,ir-1) - else - cf(in,ir) = tau(in,ir) - tau(in,ir-1) - end if - - end do - end do - - -c definition of the a(nl,nl) matrix - - do in=2,nl-1 - do ir=1,nl - if (ir.eq.in+1) a(in,ir) = -1.d0 - if (ir.eq.in-1) a(in,ir) = +1.d0 - a(in,ir) = a(in,ir) / ( 2.d0*deltaz*1.d5 ) - end do - end do -! this is not needed anymore in the akm scheme -! a(1,1) = +3.d0 -! a(1,2) = -4.d0 -! a(1,3) = +1.d0 -! a(nl,nl) = -3.d0 -! a(nl,nl1) = +4.d0 -! a(nl,nl2) = -1.d0 - -c calculation of the final curtis matrix ("reduced" by murphy's method) - - if (isot.ne.5) then - do in=1,nl - do ir=1,nl - cf(in,ir) = cf(in,ir) * pi*deltanu(isot,ib) - cfup(in,ir) = cfup(in,ir) * pi*deltanu(isot,ib) - cfdw(in,ir) = cfdw(in,ir) * pi*deltanu(isot,ib) - end do - taugr(in) = taugr(in) * pi*deltanu(isot,ib) - end do - else - do in=1,nl - do ir=1,nl - cf(in,ir) = cf(in,ir) * pi*deltanuco - enddo - taugr(in) = taugr(in) * pi*deltanuco - enddo - endif - - do in=2,nl-1 - - do ir=1,nl - - do i=1,nl - ! only c contains the matrix a. matrixes cup,cdw dont because - ! these two will be used for flux calculations, not - ! only for flux divergencies - - c(in,ir) = c(in,ir) + a(in,i) * cf(i,ir) - ! from this matrix we will extract (see below) the - ! nl2 x nl2 "core" for the "reduced" final curtis matrix. - - end do - cup(in,ir) = cfup(in,ir) - cdw(in,ir) = cfdw(in,ir) - - end do - ! version con l_bb(tg) = l_bb(t(1))=j(1) (see cf above) - !vc(in) = c(in,1) - ! version con l_bb(tg) =/= l_bb(t(1))=j(1) (see cf above) - vc(in) = pi*deltanu(isot,ib)/( 2.d0*deltaz*1.d5 ) * - @ ( tau(in-1,1) - tau(in+1,1) ) - - end do - - 5 continue - -! write (*,*) 'mztf/1/ c(2,*) =', (c(2,i), i=1,nl) - -! call elimin_dibuja(c,nl,itableout) - -c ventana del smoothing de c es nw=3 y de vc es 5 (puesto en lisa): -c subroutine elimin_mz4(c,vc,ilayer,nl,nan,iw, nw) - - iw = nan - if (isot.eq.4) iw = 5 - call elimin_mz1d (c,vc,0,iw,itableout,nw) - -! upper boundary condition -! j'(nl) = j'(nl1) ==> j(nl) = 2j(nl1) - j(nl2) ==> - do in=2,nl-1 - c(in,nl-2) = c(in,nl-2) - c(in,nl) - c(in,nl-1) = c(in,nl-1) + 2.d0*c(in,nl) - cup(in,nl-2) = cup(in,nl-2) - cup(in,nl) - cup(in,nl-1) = cup(in,nl-1) + 2.d0*cup(in,nl) - cdw(in,nl-2) = cdw(in,nl-2) - cdw(in,nl) - cdw(in,nl-1) = cdw(in,nl-1) + 2.d0*cdw(in,nl) - end do -! j(nl) = j(nl1) ==> -! do in=2,nl1 -! c(in,nl1) = c(in,nl1) + c(in,nl) -! end do - -! 1000 continue - - if (icfout.eq.1) then - -! if (ib.eq.1 .or. ib.eq.12 .or. ib.eq.16 .or. ib.eq.18) then -! codmatrx = codmatrx_fb -! else -! codmatrx = codmatrx_hot -! end if - -! if(ib.eq.1.or.ib.eq.2.or.ib.eq.3.or.ib.eq.4.or.ib.eq.5 -! @ .or.ib.eq.6.or.ib.eq.7.or.ib.eq.8.or.ib.eq.9) then - -! open ( 1, access='sequential', form='unformatted', file= -! @ dircurtis//'cfl'//isotcode//dn//ibcode1//codmatrx//'.dat') -! open ( 2, access='sequential', form='unformatted', file= -! @ dircurtis//'cflup'//isotcode//dn//ibcode1//codmatrx//'.dat') -! open ( 3, access='sequential', form='unformatted', file= -! @ dircurtis//'cfldw'//isotcode//dn//ibcode1//codmatrx//'.dat') - -! else - -! open ( 1, access='sequential', form='unformatted', file= -! @ dircurtis//'cfl'//isotcode//dn//ibcode2//codmatrx//'.dat') -! open ( 2, access='sequential', form='unformatted', file= -! @ dircurtis//'cflup'//isotcode//dn//ibcode2//codmatrx//'.dat') -! open ( 3, access='sequential', form='unformatted', file= -! @ dircurtis//'cfldw'//isotcode//dn//ibcode2//codmatrx//'.dat') - -! endif - -! write(1) dummy -! write(1)' format: (vc(n),(ch(n,r),r=2,nl-1),n=2,nl-1)' -! do in=2,nl-1 -! write(1) vc(in), (c(in,ir) , ir=2,nl-1 ) - ! es mas importante la precision que ocupar mucho espacio asi que - ! escribiremos las matrices en doble precision y por tanto en - ! [lib]readc_mz4.for no hay que reconvertirlas a doble precision. - ! ch is stored in single prec. to save storage space. -! end do - -! write(2) dummy -! write(2)' format: (cfup(n,r),r=1,nl), n=1,nl)' -! do in=1,nl -! write(2) ( cup(in,ir) , ir=1,nl ) -! end do - -! write(3) dummy -! write(3)' format: (cfdw(n,r),r=1,nl), n=1,nl)' -! do in=1,nl -! write(3) (cdw(in,ir) , ir=1,nl ) -! end do - -! if(ib.eq.1.or.ib.eq.2.or.ib.eq.3.or.ib.eq.4.or.ib.eq.5 -! @ .or.ib.eq.6.or.ib.eq.7.or.ib.eq.8.or.ib.eq.9) then -! write (*,'(1x,30hcurtis matrix written out in: ,a50)' ) -! @ dircurtis//'cfl'//isotcode//dn//ibcode1//codmatrx//'.dat' -! else -! write (*,'(1x,30hcurtis matrix written out in: ,a50)' ) -! @ dircurtis//'cfl'//isotcode//dn//ibcode2//codmatrx//'.dat' -! endif - - else - - ! write (*,*) ' no curtis matrix output file ', char(10) - - end if - - -c end - return - end Index: trunk/LMDZ.MARS/libf/phymars/mzcud.F =================================================================== --- trunk/LMDZ.MARS/libf/phymars/mzcud.F (revision 496) +++ (revision ) @@ -1,355 +1,0 @@ -c*********************************************************************** - - subroutine mzcud( tauinf,tau, c,cup,cdw,vc,taugr, - @ ib,isot,icfout,itableout ) - -c old times mlp first version of mzcf -c a.k.murphy method to avoid extrapolation in the curtis matrix -c feb-89 malv AKM method to avoid extrapolation in C.M. -c 25-sept-96 cristina dejar las matrices en doble precision -c jan 98 malv version para mz1d -c oct 01 malv update version for fluxes for hb and fb -c jul 2011 malv+fgg Adapted to LMD-MGCM -c*********************************************************************** - - implicit none - - include 'comcstfi.h' - include 'nltedefs.h' - include 'nlte_atm.h' - include 'nlte_data.h' - include 'tcr_15um.h' - include 'nlte_curtis.h' - -c arguments - real*8 c(nl,nl), cup(nl,nl), cdw(nl,nl) ! o - real*8 vc(nl), taugr(nl) ! o - real*8 tau(nl,nl) ! i - real*8 tauinf(nl) ! i - integer ib ! i - integer isot ! i - integer icfout, itableout ! i - -c external - external bandid - character*2 bandid - -c local variables - integer i, in, ir, iw, itblout - real*8 cfup(nl,nl), cfdw(nl,nl) - real*8 a(nl,nl), cf(nl,nl) - character isotcode*2, bcode*2 - -c formats - 101 format(i1) - 202 format(i2) - 180 format(a80) - 181 format(a80) -c*********************************************************************** - - if (isot.eq.1) isotcode = '26' - if (isot.eq.2) isotcode = '28' - if (isot.eq.3) isotcode = '36' - if (isot.eq.4) isotcode = '27' - if (isot.eq.5) isotcode = 'co' - bcode = bandid( ib ) - -! write (*,*) ' ' - - do in=1,nl - - do ir=1,nl - - cf(in,ir) = 0.0d0 - cfup(in,ir) = 0.0d0 - cfdw(in,ir) = 0.0d0 - c(in,ir) = 0.0d0 - cup(in,ir) = 0.0d0 - cdw(in,ir) = 0.0d0 - a(in,ir) = 0.0d0 - - end do - - vc(in) = 0.0d0 - taugr(in) = 0.0d0 - - end do - - -c the next lines are a reduced and equivalent way of calculating -c the c(in,ir) elements for n=2,nl1 and r=1,nl - - -c do in=2,nl1 -c do ir=1,nl -c if(ir.eq.1)then -c c(in,ir)=tau(in-1,1)-tau(in+1,1) -c elseif(ir.eq.nl)then -c c(in,ir)=tau(in+1,nl1)-tauinf(in+1)-tau(in-1,nl1)+tauinf(in-1) -c else -c c(in,ir)=tau(in+1,ir-1)-tau(in+1,ir)-tau(in-1,ir-1)+tau(in-1,ir) -c end if -c c(in,ir)=c(in,ir)*pi*deltanu(ib)/(2.*deltaz*1.0e5) -c end do -c end do -c go to 1000 - -c calculation of the matrix cfup(nl,nl) - - cfup(1,1) = 1.d0 - tau(1,1) - - do in=2,nl - do ir=1,in - - if (ir.eq.1) then - cfup(in,ir) = tau(in,ir) - tau(in,1) - elseif (ir.eq.in) then - cfup(in,ir) = 1.d0 - tau(in,ir-1) - else - cfup(in,ir) = tau(in,ir) - tau(in,ir-1) - end if - - end do - end do - -! contribution to upwards fluxes from bb at bottom : - do in=1,nl - taugr(in) = tau(in,1) - enddo - -c calculation of the matrix cfdw(nl,nl) - - cfdw(nl,nl) = 1.d0 - tauinf(nl) - - do in=1,nl-1 - do ir=in,nl - - if (ir.eq.in) then - cfdw(in,ir) = 1.d0 - tau(in,ir) - elseif (ir.eq.nl) then - cfdw(in,ir) = tau(in,ir-1) - tauinf(in) - else - cfdw(in,ir) = tau(in,ir-1) - tau(in,ir) - end if - - end do - end do - - -c calculation of the matrix cf(nl,nl) - - do in=1,nl - do ir=1,nl - - if (ir.eq.1) then - ! version con l_bb(tg) = l_bb(t(1))=j(1) (see also vc below) - ! cf(in,ir) = tau(in,ir) - ! version con l_bb(tg) =/= l_bb(t(1))=j(1) (see also vc below) - cf(in,ir) = tau(in,ir) - tau(in,1) - elseif (ir.eq.nl) then - cf(in,ir) = tauinf(in) - tau(in,ir-1) - else - cf(in,ir) = tau(in,ir) - tau(in,ir-1) - end if - - end do - end do - - -c definition of the a(nl,nl) matrix - - do in=2,nl-1 - do ir=1,nl - if (ir.eq.in+1) a(in,ir) = -1.d0 - if (ir.eq.in-1) a(in,ir) = +1.d0 - a(in,ir) = a(in,ir) / ( 2.d0*deltaz*1.d5 ) - end do - end do -! this is not needed anymore in the akm scheme -! a(1,1) = +3.d0 -! a(1,2) = -4.d0 -! a(1,3) = +1.d0 -! a(nl,nl) = -3.d0 -! a(nl,nl1) = +4.d0 -! a(nl,nl2) = -1.d0 - -c calculation of the final curtis matrix ("reduced" by murphy's method) - - if (isot.ne.5) then - do in=1,nl - do ir=1,nl - cf(in,ir) = cf(in,ir) * pi*deltanu(isot,ib) - cfup(in,ir) = cfup(in,ir) * pi*deltanu(isot,ib) - cfdw(in,ir) = cfdw(in,ir) * pi*deltanu(isot,ib) - end do - taugr(in) = taugr(in) * pi*deltanu(isot,ib) - end do - else - do in=1,nl - do ir=1,nl - cf(in,ir) = cf(in,ir) * pi*deltanuco - enddo - taugr(in) = taugr(in) * pi*deltanuco - enddo - endif - - do in=2,nl-1 - - do ir=1,nl - - do i=1,nl - ! only c contains the matrix a. matrixes cup,cdw dont because - ! these two will be used for flux calculations, not - ! only for flux divergencies - - c(in,ir) = c(in,ir) + a(in,i) * cf(i,ir) - ! from this matrix we will extract (see below) the - ! nl2 x nl2 "core" for the "reduced" final curtis matrix. - - end do - cup(in,ir) = cfup(in,ir) - cdw(in,ir) = cfdw(in,ir) - - end do - ! version con l_bb(tg) = l_bb(t(1))=j(1) (see cf above) - !vc(in) = c(in,1) - ! version con l_bb(tg) =/= l_bb(t(1))=j(1) (see cf above) - if (isot.ne.5) then - vc(in) = pi*deltanu(isot,ib)/( 2.d0*deltaz*1.d5 ) * - @ ( tau(in-1,1) - tau(in+1,1) ) - else - vc(in) = pi*deltanuco/( 2.d0*deltaz*1.d5 ) * - @ ( tau(in-1,1) - tau(in+1,1) ) - endif - - end do - - 5 continue - -! write (*,*) 'mztf/1/ c(2,*) =', (c(2,i), i=1,nl) - -! call elimin_dibuja(c,nl,itableout) - -c ventana del smoothing de c es nw=3 y de vc es 5 (puesto en lisa): -c subroutine elimin_mz4(c,vc,ilayer,nl,nan,iw, nw) - - iw = nan - if (isot.eq.4) iw = 5 ! eliminates values < 1.d-19 - if (itableout.eq.30) then - itblout = 0 - else - itblout = itableout - endif - call elimin_mz1d (c,vc,0,iw,itblout,nw) - -! upper boundary condition -! j'(nl) = j'(nl1) ==> j(nl) = 2j(nl1) - j(nl2) ==> - do in=2,nl-1 - c(in,nl-2) = c(in,nl-2) - c(in,nl) - c(in,nl-1) = c(in,nl-1) + 2.d0*c(in,nl) - cup(in,nl-2) = cup(in,nl-2) - cup(in,nl) - cup(in,nl-1) = cup(in,nl-1) + 2.d0*cup(in,nl) - cdw(in,nl-2) = cdw(in,nl-2) - cdw(in,nl) - cdw(in,nl-1) = cdw(in,nl-1) + 2.d0*cdw(in,nl) - end do -! j(nl) = j(nl1) ==> -! do in=2,nl1 -! c(in,nl1) = c(in,nl1) + c(in,nl) -! end do - -! 1000 continue - - - if (icfout.eq.1) then - -! if (ib.eq.1 .or. ib.eq.12 .or. ib.eq.16 .or. ib.eq.18) then -! codmatrx = codmatrx_fb -! else -! codmatrx = codmatrx_hot -! end if -! if (ib.eq.1.or.ib.eq.2.or.ib.eq.3.or.ib.eq.4.or.ib.eq.5 -! @ .or.ib.eq.6.or.ib.eq.7.or.ib.eq.8.or.ib.eq.9) then -! ibcode2 = '0'//ibcode1 -! else -! write ( ibcode2, 202) ib -! endif - -! open ( 1, access='sequential', form='unformatted', file= -! @ dircurtis//'cfl'//isotcode//dn//ibcode2//codmatrx//'.dat') -! open ( 2, access='sequential', form='unformatted', file= -! @ dircurtis//'cflup'//isotcode//dn//ibcode2//codmatrx//'.dat') -! open ( 3, access='sequential', form='unformatted', file= -! @ dircurtis//'cfldw'//isotcode//dn//ibcode2//codmatrx//'.dat') -! open ( 4, access='sequential', form='unformatted', file= -! @ dircurtis//'cflgr'//isotcode//dn//ibcode2//codmatrx//'.dat') - -! write(1) dummy -! write(1) ' format: (vc(n),(ch(n,r),r=2,nl-1),n=2,nl-1)' -! do in=2,nl-1 -! write(1) vc(in), (c(in,ir) , ir=2,nl-1 ) -!! write (*,*) in, vc(in) -! end do - -! write(2) dummy -! write(2)' format: (cfup(n,r),r=1,nl), n=1,nl)' -! do in=1,nl -! write(2) ( cup(in,ir) , ir=1,nl ) -! end do - -! write(3) dummy -! write(3)' format: (cfdw(n,r),r=1,nl), n=1,nl)' -! do in=1,nl -! write(3) (cdw(in,ir) , ir=1,nl ) -! end do - -! write(4) dummy -! write(4)' format: (taugr(n), n=1,nl)' -! do in=1,nl -! write(4) (taugr(in), ir=1,nl ) -! end do -! !write (*,*) ' Last value in file: ', taugr(nl) - -! write (*,'(1x,30hcurtis matrix written out in: ,a,a,a,a)' ) -! @ dircurtis//'cfl'//isotcode//dn//ibcode2//codmatrx//'.dat', -! @ dircurtis//'cflup'//isotcode//dn//ibcode2//codmatrx//'.dat', -! @ dircurtis//'cfldw'//isotcode//dn//ibcode2//codmatrx//'.dat', -! @ dircurtis//'cflgr'//isotcode//dn//ibcode2//codmatrx//'.dat' - -! close (1) -! close (2) -! close (3) -! close (4) - - else - - ! write (*,*) ' no curtis matrix output file ', char(10) - - end if - - if (itableout.eq.30) then ! Force output of C.M. in ascii file - -! if (ib.eq.1 .or. ib.eq.12 .or. ib.eq.16 .or. ib.eq.18) then -! codmatrx = codmatrx_fb -! else -! codmatrx = codmatrx_hot -! end if -! if (ib.eq.1.or.ib.eq.2.or.ib.eq.3.or.ib.eq.4.or.ib.eq.5 -! @ .or.ib.eq.6.or.ib.eq.7.or.ib.eq.8.or.ib.eq.9) then -! ibcode2 = '0'//ibcode1 -! else -! write ( ibcode2, 202) ib -! endif - -! open (10, file= -! & dircurtis//'table'//isotcode//dn//ibcode2//codmatrx//'.dat') -! write(10,*) nl, ' = number of layers ' -! write(10,*) ' format: (vc(n),(ch(n,r),r=2,nl-1),n=2,nl-1)' -! do in=2,nl-1 -! write(10,*) vc(in), (c(in,ir) , ir=2,nl-1 ) -! enddo -! close (10) - endif - -c end - return - end Index: trunk/LMDZ.MARS/libf/phymars/mzescape.F =================================================================== --- trunk/LMDZ.MARS/libf/phymars/mzescape.F (revision 496) +++ (revision ) @@ -1,599 +1,0 @@ -c*********************************************************************** -c mzescape.f -c*********************************************************************** -c -c program for calculating atmospheric escape functions, from -c a calculation of transmittances and derivatives of these ones - - subroutine mzescape(ig,taustar,tauinf,tauii, ib,isot, iirw,iimu) - -c jul 2011 malv+fgg adapted to LMD-MGCM -c nov 99 malv adapt mztf to compute taustar (pg.23b-ma -c nov 98 malv allow for overlaping in the lorentz line -c jan 98 malv version for mz1d. based on curtis/mztf.for -c 17-jul-96 mlp&crs change the calculation of mr. -c evitar: divide por cero. anhadiendo: ff -c oct-92 malv correct s(t) dependence for all histogr bands -c june-92 malv proper lower levels for laser bands -c may-92 malv new temperature dependence for laser bands -c @ 991 malv boxing for the averaged absorber amount and t -c ? malv extension up to 200 km altitude in mars -c 13-nov-86 mlp include the temperature weighted to match -c the eqw in the strong doppler limit. -c*********************************************************************** - - implicit none - - include 'nltedefs.h' - include 'nlte_atm.h' - include 'nlte_data.h' - include 'nlte_curtis.h' - include 'tcr_15um.h' - include 'nlte_results.h' - - -c arguments - integer ig ! ADDED FOR TRACEBACK - real*8 taustar(nl) ! o - real*8 tauinf(nl) ! o - real*8 tauii(nl) ! o - integer ib ! i - integer isot ! i - integer iirw ! i - integer iimu ! i - - -c local variables and constants - integer i, in, ir, im, k,j - integer nmu - parameter (nmu = 8) -! real*8 tauinf(nl) - real*8 con(nzy), coninf - real*8 c1, c2, ccc - real*8 t1, t2 - real*8 p1, p2 - real*8 mr1, mr2 - real*8 st1, st2 - real*8 c1box(70), c2box(70) - real*8 ff ! to avoid too small numbers - real*8 tvtbs(nzy) - real*8 st, beta, ts, eqwmu - real*8 mu(nmu), amu(nmu) - real*8 zld(nl), zyd(nzy) - real*8 correc - real deltanux ! width of vib-rot band (cm-1) - character isotcode*2 - real*8 maximum - real*8 csL, psL, Desp, wsL ! for Strong Lorentz limit - -c formats - 111 format(a1) - 112 format(a2) - 101 format(i1) - 202 format(i2) - 180 format(a80) - 181 format(a80) -c*********************************************************************** - -c some needed values -! rl=sqrt(log(2.d0)) -! pi2 = 3.14159265358989d0 - beta = 1.8d0 -! imrco = 0.9865 - -c esto es para que las subroutines de mztfsub calculen we -c de la forma apropiada para mztf, no para fot - icls=icls_mztf - -c codigos para filenames -! if (isot .eq. 1) isotcode = '26' -! if (isot .eq. 2) isotcode = '28' -! if (isot .eq. 3) isotcode = '36' -! if (isot .eq. 4) isotcode = '27' -! if (isot .eq. 5) isotcode = '62' -! if(ib.eq.1.or.ib.eq.2.or.ib.eq.3.or.ib.eq.4.or.ib.eq.5 -! @ .or.ib.eq.6.or.ib.eq.7.or.ib.eq.8.or.ib.eq.9) then -!! encode(2,101,ibcode1)ib -! write ( ibcode1, 101) ib -! else -!! encode(2,202,ibcode2)ib -! write (ibcode2, 202) ib -! endif -! write (*,'( 30h calculating curtis matrix : ,2x, -! @ 8h band = ,i2,2x, 11h isotope = ,i2)') ib, isot - -c integration in angle !!!!!!!!!!!!!!!!!!!! - -c------- diffusivity approx. - if (iimu.eq.1) then -! write (*,*) ' diffusivity approx. beta = ',beta - mu(1) = 1.0d0 - amu(1)= 1.0d0 -c-------data for 8 points integration - elseif (iimu.eq.4) then - write (*,*)' 4 points for the gauss-legendre angle quadrature.' - mu(1)=(1.0d0+0.339981043584856)/2.0d0 - mu(2)=(1.0d0-0.339981043584856)/2.0d0 - mu(3)=(1.0d0+0.861136311594053)/2.0d0 - mu(4)=(1.0d0-0.861136311594053)/2.0d0 - amu(1)=0.652145154862546 - amu(2)=amu(1) - amu(3)=0.347854845137454 - amu(4)=amu(3) - beta=1.0d0 -c-------data for 8 points integration - elseif(iimu.eq.8) then - write (*,*)' 8 points for the gauss-legendre angle quadrature.' - mu(1)=(1.0d0+0.183434642495650)/2.0d0 - mu(2)=(1.0d0-0.183434642495650)/2.0d0 - mu(3)=(1.0d0+0.525532409916329)/2.0d0 - mu(4)=(1.0d0-0.525532409916329)/2.0d0 - mu(5)=(1.0d0+0.796666477413627)/2.0d0 - mu(6)=(1.0d0-0.796666477413627)/2.0d0 - mu(7)=(1.0d0+0.960289856497536)/2.0d0 - mu(8)=(1.0d0-0.960289856497536)/2.0d0 - amu(1)=0.362683783378362 - amu(2)=amu(1) - amu(3)=0.313706645877887 - amu(4)=amu(3) - amu(5)=0.222381034453374 - amu(6)=amu(5) - amu(7)=0.101228536290376 - amu(8)=amu(7) - beta=1.0d0 - end if -c!!!!!!!!!!!!!!!!!!!!!!! - -ccc -ccc determine abundances included in the absorber amount -ccc - -c first, set up the grid ready for interpolation. - do i=1,nzy - zyd(i) = dble(zy(i)) - enddo - do i=1,nl - zld(i) = dble(zl(i)) - enddo - -c vibr. temp of the bending mode : - if (isot.eq.1) call interdp ( tvtbs,zyd,nzy, v626t1,zld,nl, 1 ) - if (isot.eq.2) call interdp ( tvtbs,zyd,nzy, v628t1,zld,nl, 1 ) - if (isot.eq.3) call interdp ( tvtbs,zyd,nzy, v636t1,zld,nl, 1 ) - if (isot.eq.4) call interdp ( tvtbs,zyd,nzy, v627t1,zld,nl, 1 ) - -c 2nd: correccion a la n10(i) (cantidad de absorbente en el lower state) -c por similitud a la que se hace en cza.for - - do i=1,nzy - if (isot.eq.5) then - con(i) = dble( coy(i) * imrco ) - else - con(i) = dble( co2y(i) * imr(isot) ) - correc = 2.d0 * dexp( dble(-ee*elow(isot,2))/tvtbs(i) ) - con(i) = con(i) * ( 1.d0 - correc ) - endif -c----------------------------------------------------------------------- -c mlp & cristina. 17 july 1996 -c change the calculation of mr. it is used for calculating partial press -c alpha = alpha(self,co2)*pp +alpha(n2)*(pt-pp) -c for an isotope, if mr is obtained by co2*imr(iso)/nt we are considerin -c collisions with other co2 isotopes (including the major one, 626) -c as if they were with n2. assuming mr as co2/nt, we consider collisions -c of type 628-626 as of 626-626 instead of as 626-n2. -c mrx(i)=con(i)/ntx(i) ! old malv - -! mrx(i)= dble(co2x(i)/ntx(i)) ! mlp & crs - -c jan 98: -c esta modif de mlp implica anular el correc (deberia revisar esto) - mr(i) = dble(co2y(i)/nty(i)) ! malv, jan 98 - -c----------------------------------------------------------------------- - - end do - -! como beta y 1.d5 son comunes a todas las weighted absorber amounts, -! los simplificamos: -! coninf = beta * 1.d5 * dble( con(n) / log( con(n-1) / con(n) ) ) - coninf = dble( con(nzy) / log( con(nzy-1) / con(nzy) ) ) - -! write (*,*) ' coninf =', coninf - -ccc -ccc temp dependence of the band strength and -ccc nlte correction factor for the absorber amount -ccc - call mztf_correccion ( coninf, con, ib, isot, 0 ) - -ccc -ccc reads histogrammed spectral data (strength for lte and vmr=1) -ccc - !hfile1 = dirspec//'hi'//dn ! Ya no distinguimos entre d/n -!! hfile1 = dirspec//'hid' ! (see why in his.for) -! hfile1='hid' -!! if (ib.eq.13 .or. ib.eq.14 ) hfile1 = dirspec//'his' -! if (ib.eq.13 .or. ib.eq.14 ) hfile1 = 'his' - -! if(ib.eq.1.or.ib.eq.2.or.ib.eq.3.or.ib.eq.4.or.ib.eq.5 -! @ .or.ib.eq.6.or.ib.eq.7.or.ib.eq.8.or.ib.eq.9) then -! if (isot.eq.1) hisfile = hfile1//'26-'//ibcode1//'.dat' -! if (isot.eq.2) hisfile = hfile1//'28-'//ibcode1//'.dat' -! if (isot.eq.3) hisfile = hfile1//'36-'//ibcode1//'.dat' -! if (isot.eq.4) hisfile = hfile1//'27-'//ibcode1//'.dat' -! if (isot.eq.5) hisfile = hfile1//'62-'//ibcode1//'.dat' -! else -! if (isot.eq.1) hisfile = hfile1//'26-'//ibcode2//'.dat' -! if (isot.eq.2) hisfile = hfile1//'28-'//ibcode2//'.dat' -! if (isot.eq.3) hisfile = hfile1//'36-'//ibcode2//'.dat' -! if (isot.eq.4) hisfile = hfile1//'27-'//ibcode2//'.dat' -! if (isot.eq.5) hisfile = hfile1//'62-'//ibcode2//'.dat' -! endif - !write (*,*) ' /MZESCAPE/ hisfile: ', hisfile - -! the argument to rhist is to make this compatible with mztf_comp.f, -! which is a useful modification of mztf.f (to change strengths of bands -! call rhist (1.0) - if(ib.eq.1) then - if(isot.eq.1) then !Case 1 - mm=mm_c1 - nbox=nbox_c1 - tmin=tmin_c1 - tmax=tmax_c1 - do i=1,nbox_max - no(i)=no_c1(i) - dist(i)=dist_c1(i) - do j=1,nhist - sk1(j,i)=sk1_c1(j,i) - xls1(j,i)=xls1_c1(j,i) - xln1(j,i)=xln1_c1(j,i) - xld1(j,i)=xld1_c1(j,i) - enddo - enddo - do j=1,nhist - thist(j)=thist_c1(j) - enddo - else if(isot.eq.2) then !Case 2 - mm=mm_c2 - nbox=nbox_c2 - tmin=tmin_c2 - tmax=tmax_c2 - do i=1,nbox_max - no(i)=no_c2(i) - dist(i)=dist_c2(i) - do j=1,nhist - sk1(j,i)=sk1_c2(j,i) - xls1(j,i)=xls1_c2(j,i) - xln1(j,i)=xln1_c2(j,i) - xld1(j,i)=xld1_c2(j,i) - enddo - enddo - do j=1,nhist - thist(j)=thist_c2(j) - enddo - else if(isot.eq.3) then !Case 3 - mm=mm_c3 - nbox=nbox_c3 - tmin=tmin_c3 - tmax=tmax_c3 - do i=1,nbox_max - no(i)=no_c3(i) - dist(i)=dist_c3(i) - do j=1,nhist - sk1(j,i)=sk1_c3(j,i) - xls1(j,i)=xls1_c3(j,i) - xln1(j,i)=xln1_c3(j,i) - xld1(j,i)=xld1_c3(j,i) - enddo - enddo - do j=1,nhist - thist(j)=thist_c3(j) - enddo - else if(isot.eq.4) then !Case 4 - mm=mm_c4 - nbox=nbox_c4 - tmin=tmin_c4 - tmax=tmax_c4 - do i=1,nbox_max - no(i)=no_c4(i) - dist(i)=dist_c4(i) - do j=1,nhist - sk1(j,i)=sk1_c4(j,i) - xls1(j,i)=xls1_c4(j,i) - xln1(j,i)=xln1_c4(j,i) - xld1(j,i)=xld1_c4(j,i) - enddo - enddo - do j=1,nhist - thist(j)=thist_c4(j) - enddo - else - write(*,*)'isot must be 2,3 or 4 for ib=1!!' - write(*,*)'stop at mzescape/312' - stop - endif - else if (ib.eq.2) then - if(isot.eq.1) then !Case 5 - mm=mm_c5 - nbox=nbox_c5 - tmin=tmin_c5 - tmax=tmax_c5 - do i=1,nbox_max - no(i)=no_c5(i) - dist(i)=dist_c5(i) - do j=1,nhist - sk1(j,i)=sk1_c5(j,i) - xls1(j,i)=xls1_c5(j,i) - xln1(j,i)=xln1_c5(j,i) - xld1(j,i)=xld1_c5(j,i) - enddo - enddo - do j=1,nhist - thist(j)=thist_c5(j) - enddo - else - write(*,*)'isot must be 1 for ib=2!!' - write(*,*)'stop at mzescape/336' - stop - endif - else if (ib.eq.3) then - if(isot.eq.1) then !Case 6 - mm=mm_c6 - nbox=nbox_c6 - tmin=tmin_c6 - tmax=tmax_c6 - do i=1,nbox_max - no(i)=no_c6(i) - dist(i)=dist_c6(i) - do j=1,nhist - sk1(j,i)=sk1_c6(j,i) - xls1(j,i)=xls1_c6(j,i) - xln1(j,i)=xln1_c6(j,i) - xld1(j,i)=xld1_c6(j,i) - enddo - enddo - do j=1,nhist - thist(j)=thist_c6(j) - enddo - else - write(*,*)'isot must be 1 for ib=3!!' - write(*,*)'stop at mzescape/360' - stop - endif - else if (ib.eq.4) then - if(isot.eq.1) then !Case 7 - mm=mm_c7 - nbox=nbox_c7 - tmin=tmin_c7 - tmax=tmax_c7 - do i=1,nbox_max - no(i)=no_c7(i) - dist(i)=dist_c7(i) - do j=1,nhist - sk1(j,i)=sk1_c7(j,i) - xls1(j,i)=xls1_c7(j,i) - xln1(j,i)=xln1_c7(j,i) - xld1(j,i)=xld1_c7(j,i) - enddo - enddo - do j=1,nhist - thist(j)=thist_c7(j) - enddo - else - write(*,*)'isot must be 1 for ib=4!!' - write(*,*)'stop at mzescape/384' - stop - endif - else - write(*,*)'ib must be 1,2,3 or 4!!' - write(*,*)'stop at mzescape/389' - endif - if (isot.ne.5) deltanux = deltanu(isot,ib) - if (isot.eq.5) deltanux = deltanuco - -c****** -c****** calculation of tauinf(nl) -c****** - call initial - - ff=1.0e10 - - do i=nl,1,-1 - - if(i.eq.nl)then - - call intz (zl(i),c2,p2,mr2,t2, con) - do kr=1,nbox - ta(kr)=t2 - end do -! write (*,*) ' i, t2 =', i, t2 - call interstrength (st2,t2,ka,ta) - aa = p2 * coninf * mr2 * (st2 * ff) - bb = p2 * coninf * st2 - cc = coninf * st2 - dd = t2 * coninf * st2 - do kr=1,nbox - ccbox(kr) = coninf * ka(kr) - ddbox(kr) = t2 * ccbox(kr) -! c2box(kr) = c2 * ka(kr) * beta * dble(deltaz) * 1.d5 - c2box(kr) = c2 * ka(kr) * dble(deltaz) - end do -! c2 = c2 * st2 * beta * dble(deltaz) * 1.d5 - c2 = c2 * st2 * dble(deltaz) - - else - call intz (zl(i),c1,p1,mr1,t1, con) - do kr=1,nbox - ta(kr)=t1 - end do -! write (*,*) ' i, t1 =', i, t1 - call interstrength (st1,t1,ka,ta) - do kr=1,nbox -! c1box(kr) = c1 * ka(kr) * beta * dble(deltaz) * 1.d5 - c1box(kr) = c1 * ka(kr) * dble(deltaz) - end do -! c1 = c1 * st1 * beta * dble(deltaz) * 1.d5 - c1 = c1 * st1 * dble(deltaz) - aa = aa + ( p1*mr1*(c1*ff) + p2*mr2*(c2*ff)) / 2.d0 - bb = bb + ( p1*c1 + p2*c2 ) / 2.d0 - cc = cc + ( c1 + c2 ) / 2.d0 - ccc = ( c1 + c2 ) / 2.d0 - dd = dd + ( t1*c1 + t2*c2 ) / 2.d0 - do kr=1,nbox - ccbox(kr) = ccbox(kr) + - @ ( c1box(kr) + c2box(kr) )/2.d0 - ddbox(kr) = ddbox(kr) + - @ ( t1*c1box(kr)+t2*c2box(kr) )/2.d0 - end do - - mr2 = mr1 - c2=c1 - do kr=1,nbox - c2box(kr) = c1box(kr) - end do - t2=t1 - p2=p1 - end if - - pt = bb / cc - pp = aa / (cc*ff) - -! ta=dd/cc -! tdop = ta - ts = dd/cc - do kr=1,nbox - ta(kr) = ddbox(kr) / ccbox(kr) - end do -! write (*,*) ' i, ts =', i, ts - call interstrength(st,ts,ka,ta) -! call intershape(alsa,alna,alda,tdop) - call intershape(alsa,alna,alda,ta) - -* ua = cc/st - -c next loop calculates the eqw for an especified path ua,pp,pt,ta - - eqwmu = 0.0d0 - do im = 1,iimu - eqw=0.0d0 - do kr=1,nbox - ua(kr) = ccbox(kr) / ka(kr) * beta * 1.0d5 / mu(im) - if(ua(kr).lt.0.)write(*,*)'mzescape/480',ua(kr), - $ ccbox(kr),ka(kr),beta,mu(im),kr,im,i,nl - - call findw (ig,iirw, 0, csL,psL, Desp, wsL) - if ( i_supersat .eq. 0 ) then - eqw=eqw+no(kr)*w - else - eqw = w + (no(kr)-1) * ( asat_box*dist(kr) ) - endif - end do - eqwmu = eqwmu + eqw * mu(im)*amu(im) - end do - -! tauinf(i) = exp( - eqwmu / dble(deltanux) ) - tauinf(i) = 1.d0 - eqwmu / dble(deltanux) - if (tauinf(i).lt.0.d0) tauinf(i) = 0.0d0 - - if (i.eq.nl) then - taustar(i) = 0.0d0 - else - taustar(i) = dble(deltanux) * (tauinf(i+1)-tauinf(i)) -! ~ / ( beta * cc * 1.d5 ) - ~ / ( beta * ccc * 1.d5 ) - endif - - end do ! i continue - - -c****** -c****** calculation of tau(in,ir) for n<=r -c****** - - do 1 in=1,nl-1 - - call initial - - call intz (zl(in), c1,p1,mr1,t1, con) - do kr=1,nbox - ta(kr) = t1 - end do - call interstrength (st1,t1,ka,ta) - do kr=1,nbox - c1box(kr) = c1 * ka(kr) * dble(deltaz) - end do - c1 = c1 * st1 * dble(deltaz) - - call intz (zl(in+1), c2,p2,mr2,t2, con) - do kr=1,nbox - ta(kr) = t2 - end do - call interstrength (st2,t2,ka,ta) - do kr=1,nbox - c2box(kr) = c2 * ka(kr) * dble(deltaz) - end do - c2 = c2 * st2 * dble(deltaz) - - aa = aa + ( p1*mr1*(c1*ff) + p2*mr2*(c2*ff)) / 2.d0 - bb = bb + ( p1*c1 + p2*c2 ) / 2.d0 - cc = cc + ( c1 + c2 ) / 2.d0 - dd = dd + ( t1*c1 + t2*c2 ) / 2.d0 - do kr=1,nbox - ccbox(kr) = ccbox(kr) + (c1box(kr)+c2box(kr))/2.d0 - ddbox(kr) = ddbox(kr) + (t1*c1box(kr)+t2*c2box(kr))/2.d0 - end do - - mr1=mr2 - t1=t2 - c1=c2 - p1=p2 - do kr=1,nbox - c1box(kr) = c2box(kr) - end do - pt = bb / cc - pp = aa / (cc * ff) - ts = dd/cc - do kr=1,nbox - ta(kr) = ddbox(kr) / ccbox(kr) - end do - call interstrength(st,ts,ka,ta) - call intershape(alsa,alna,alda,ta) - - eqwmu = 0.0d0 - do im = 1,iimu - eqw=0.0d0 - do kr=1,nbox - ua(kr) = ccbox(kr) / ka(kr) * beta * 1.0d5 / mu(im) - if(ua(kr).lt.0.)write(*,*)'mzescape/566',ua(kr), - $ ccbox(kr),ka(kr),beta,mu(im),kr,im,i,nl - - call findw (ig,iirw, 0, csL,psL, Desp, wsL) - if ( i_supersat .eq. 0 ) then - eqw=eqw+no(kr)*w - else - eqw = w + (no(kr)-1) * ( asat_box*dist(kr) ) - endif - end do - eqwmu = eqwmu + eqw * mu(im)*amu(im) - end do - - tauii(in) = exp( - eqwmu / dble(deltanux) ) - !write (*,*) 'i,tauii=',in,tauii(in) - - 1 continue - tauii(nl) = 1.0d0 - - -c end - return - end - - - - - - - - - - Index: trunk/LMDZ.MARS/libf/phymars/mzescape_fb.F =================================================================== --- trunk/LMDZ.MARS/libf/phymars/mzescape_fb.F (revision 496) +++ (revision ) @@ -1,47 +1,0 @@ -c*********************************************************************** - subroutine mzescape_fb(ig) - -c computes the escape functions of the most important 15um bands -c this calls mzescape ( taustar,tauinf,tauii, ib,isot, iirw,iimu - -c nov 99 malv based on cm15um_fb.f -c jul 2011 malv+fgg adapted to LMD-MGCM -c*********************************************************************** - - implicit none - - include 'nltedefs.h' - include 'nlte_matrix.h' - include 'nlte_atm.h' - include 'tcr_15um.h' - -c local variables - integer i, ib, ik, istyle - integer ig !ADDED FOR TRACEBACK - real*8 tau_factor - real*8 aux(nl), aux2(nl), aux3(nl) - -c*********************************************************************** - - call mzescape ( ig,taustar21,tauinf210,tauii210, 1, 2,irw_mztf,imu ) - call mzescape ( ig,taustar31,tauinf310,tauii310, 1, 3,irw_mztf,imu ) - call mzescape ( ig,taustar41,tauinf410,tauii410, 1, 4,irw_mztf,imu ) - - istyle = 2 - call mzescape_normaliz ( taustar21, istyle ) - call mzescape_normaliz ( taustar31, istyle ) - call mzescape_normaliz ( taustar41, istyle ) - - -c end - return - end - - - - - - - - - Index: trunk/LMDZ.MARS/libf/phymars/mzescape_fh.F =================================================================== --- trunk/LMDZ.MARS/libf/phymars/mzescape_fh.F (revision 496) +++ (revision ) @@ -1,52 +1,0 @@ -c*********************************************************************** - subroutine mzescape_fh(ig) - -c jul 2011 malv+fgg -c*********************************************************************** - - implicit none - - include 'nltedefs.h' - include 'nlte_matrix.h' - include 'nlte_atm.h' - include 'tcr_15um.h' - -c local variables - integer i, ib, ik, istyle - integer ig ! ADDED FOR TRACEBACK - real*8 tau_factor - real*8 aux(nl), aux2(nl), aux3(nl) - -c*********************************************************************** - - call zero4v( aux, taustar12,tauinf121,tauii121, nl) - do ik=1,3 - ib=ik+1 - call mzescape ( ig,aux,aux2,aux3, ib, 1,irw_mztf,imu ) - tau_factor = 1.d0 - if (ik.eq.1) tau_factor = dble(667.75/618.03) - if (ik.eq.3) tau_factor = dble(667.75/720.806) - do i=1,nl - taustar12(i) = taustar12(i) + aux(i) * tau_factor - tauinf121(i) = tauinf121(i) + aux2(i) * tau_factor - tauii121(i) = tauii121(i) + aux3(i) * tau_factor - enddo - enddo - - istyle = 2 - call mzescape_normaliz ( taustar12, istyle ) - - - -c end - return - end - - - - - - - - - Index: trunk/LMDZ.MARS/libf/phymars/mzescape_normaliz.F =================================================================== --- trunk/LMDZ.MARS/libf/phymars/mzescape_normaliz.F (revision 496) +++ (revision ) @@ -1,83 +1,0 @@ -c*********************************************************************** -c mzescape_normaliz.f -c*********************************************************************** -c -c program for correcting some strange values and for normalizing -c the atmospheric escape functions computed by mzescape_15um.f -c possibilities according to istyle (see mzescape_15um.f). -c - - subroutine mzescape_normaliz ( taustar, istyle ) - - -c dic 99 malv first version -c jul 2011 malv+fgg Adapted to LMD-MGCM -c*********************************************************************** - - implicit none - include 'nltedefs.h' - - -c arguments - real*8 taustar(nl) ! o - integer istyle ! i - -c local variables and constants - integer i, imaximum - real*8 maximum - -c*********************************************************************** - -! -! correcting strange values at top, eliminating local maxima, etc... -! - taustar(nl) = taustar(nl-1) - - if ( istyle .eq. 1 ) then - imaximum = nl - maximum = taustar(nl) - do i=1,nl-1 - if (taustar(i).gt.maximum) taustar(i) = taustar(nl) - enddo - elseif ( istyle .eq. 2 ) then - imaximum = nl - maximum = taustar(nl) - do i=nl-1,1,-1 - if (taustar(i).gt.maximum) then - maximum = taustar(i) - imaximum = i - endif - enddo - do i=imaximum,nl - if (taustar(i).lt.maximum) taustar(i) = maximum - enddo - endif - -! -! normalizing -! - do i=1,nl - taustar(i) = taustar(i) / maximum - enddo - - -c end - return - end - - - - - - - - - - - - - - - - - Index: trunk/LMDZ.MARS/libf/phymars/mztf_correccion.F =================================================================== --- trunk/LMDZ.MARS/libf/phymars/mztf_correccion.F (revision 496) +++ (revision ) @@ -1,306 +1,0 @@ -c*********************************************************************** - - subroutine mztf_correccion (coninf, con, ib, isot, icurt_pop) - -c including the dependence of the absort. coeff. on temp., vibr. temp., -c function, etc.., when neccessary. imr is already corrected in his.for -c we follow pg.39b-43a (l5): -c tvt1 is the vibr temp of the upper level -c tvt is the vibr temp of the transition itself -c tvtbs is the vibr temp of the bending mode (used in qv) -c for fundamental bands, they are not used at the moment. -c for the 15 fh and sh bands, only tvt0 is used at the moment. -c for the laser band, all of them are used following pg. 41a -l5- : -c we need s(z) and we can read s(tk) from the histogram (also called -c what we have to calculate now is the factor s(z)/s(tk) or following -c l5 notebook notation, s_nlte/s_lte. -c s_nlte/s_lte = xfactor = xlower * xqv * xes - -c icurt_pop = 30 -> Output of populations of the 0200,0220,1000 states -c = otro -> no output of these populations - -c oct 92 malv -c jan 98 malv version for mz1d -c jul 2011 malv+fgg adapted to LMD-MGCM -c*********************************************************************** - - implicit none - - include 'nltedefs.h' - include 'nlte_atm.h' - include 'nlte_data.h' - include 'nlte_results.h' - include 'nlte_curtis.h' - -c arguments - integer ib, isot - integer icurt_pop ! output of Fermi states population - real*8 con(nzy), coninf - -! local variables - integer i - real*8 tvt0(nzy),tvt1(nzy),tvtbs(nzy), zld(nl),zyd(nzy) - real xalfa, xbeta, xtv1000, xtv0200, xtv0220, xfactor - real xqv, xnu_trans, xtv_trans, xes, xlower -c*********************************************************************** - - xfactor = 1.0 - - do i=1,nzy - zyd(i) = dble(zy(i)) - enddo - do i=1,nl - zld(i) = dble( zl(i) ) - end do - -! tvtbs is the bending mode of the molecule. used in xqv. - if (isot.eq.1) call interdp (tvtbs,zyd,nzy, v626t1,zld,nl, 1 ) - if (isot.eq.2) call interdp (tvtbs,zyd,nzy, v628t1,zld,nl, 1 ) - if (isot.eq.3) call interdp (tvtbs,zyd,nzy, v636t1,zld,nl, 1 ) - if (isot.eq.4) call interdp (tvtbs,zyd,nzy, v627t1,zld,nl, 1 ) - if (isot.eq.5) call interdp (tvtbs,zyd,nzy, vcot1,zld,nl, 1 ) - -! tvt0 is the lower level of the transition. used in xlower. - if (ib.eq.2 .or. ib.eq.3 .or. ib.eq.4 .or. ib.eq.15) then - if (isot.eq.1) call interdp (tvt0,zyd,nzy, v626t1,zld,nl, 1 ) - if (isot.eq.2) call interdp (tvt0,zyd,nzy, v628t1,zld,nl, 1 ) - if (isot.eq.3) call interdp (tvt0,zyd,nzy, v636t1,zld,nl, 1 ) - if (isot.eq.4) call interdp (tvt0,zyd,nzy, v627t1,zld,nl, 1 ) - elseif (ib.eq.6 .or. ib.eq.8 .or. ib.eq.10 - @ .or. ib.eq.13 .or. ib.eq.14 - @ .or. ib.eq.17 .or. ib.eq.19 .or. ib.eq.20) then - if (isot.eq.1) call interdp ( tvt0,zyd,nzy, v626t2,zld,nl, 1 ) - if (isot.eq.2) call interdp ( tvt0,zyd,nzy, v628t2,zld,nl, 1 ) - if (isot.eq.3) call interdp ( tvt0,zyd,nzy, v636t2,zld,nl, 1 ) - if (isot.eq.4) then - call interdp ( tvt0,zyd,nzy, v627t2,zld,nl, 1 ) - endif - else - do i=1,nzy - tvt0(i) = dble( ty(i) ) - end do - end if - -c tvt is the vt of the transition. used in xes. -c since xes=1.0 except for the laser bands, tvt is only needed for them -c but it is actually calculated from the tv of the upper and lower level -c of the transition. hence, only tvt1 remains to be read for the laser b -c tvt1 is the upper level of the transition. - if (ib.eq.13 .or. ib.eq.14) then - if (isot.eq.1) call interdp ( tvt1,zyd,nzy, v626t4,zld,nl, 1 ) - if (isot.eq.2) call interdp ( tvt1,zyd,nzy, v628t4,zld,nl, 1 ) - if (isot.eq.3) call interdp ( tvt1,zyd,nzy, v636t4,zld,nl, 1 ) - if (isot.eq.4) call interdp ( tvt1,zyd,nzy, v627t4,zld,nl, 1 ) - end if - -c here we weight the absorber amount by a factor which compensate the l -c value of the strength read from hitran. we use that factor in order t -c correct the product s*m when we later multiply those two variables. - -! if ( isot.eq.1 .and. icurt_pop.eq.30 ) then -! open (30, file='020populations.dat') -! write (30,*) ' z tv(020) tv0200 tv0220 tv1000 ' -! endif - - do i=1,nzy - - if (isot.eq.1) then - - !!! vt of the 3 levels in (020) (see pag. 36a-sn1 for this) - xalfa = 1.d0/2.d0* exp( dble(-ee*(nu12_1000-nu(1,2))/ty(i)) ) - xbeta = 1.d0/2.d0* exp( dble(-ee*(nu12_0200-nu(1,2))/ty(i)) ) - xtv0200 = dble( - ee * nu12_0200 ) / - @ ( log( xbeta/(1.d0+xalfa+xbeta) ) - - @ dble(ee*nu(1,2))/tvt0(i) ) - xtv0220 = dble( - ee * nu(1,2) ) / - @ ( log( 1.d0/(1.d0+xalfa+xbeta) ) - - @ dble(ee*nu(1,2))/tvt0(i) ) - xtv1000 = dble( - ee * nu12_1000 ) / - @ ( log( xalfa/(1.d0+xalfa+xbeta) ) - - @ dble(ee*nu(1,2))/tvt0(i) ) - !!! correccion 8-Nov-04 (see pag.9b-Marte4-) - xtv0200 = dble( - ee * nu12_0200 / - @ ( log(4.*xbeta/(1.d0+xalfa+xbeta)) - ee*nu(1,2)/tvt0(i) ) ) - xtv0220 = dble( - ee * nu(1,2) / - @ ( log(2./(1.d0+xalfa+xbeta)) - ee*nu(1,2)/tvt0(i) ) ) - xtv1000 = dble( - ee * nu12_1000 / - @ ( log(4.*xalfa/(1.d0+xalfa+xbeta)) - ee*nu(1,2)/tvt0(i) ) ) - -! if ( icurt_pop.eq.30 ) then -! write (30,'( 1x,f7.2, 3x,f8.3, 2x,3(1x,f8.3) )') -! @ zx(i), tvt0(i), xtv0200, xtv0220, xtv1000 -! endif - - !!! xlower and xes for the band - if (ib.eq.19) then - xlower = exp( dble(ee*elow(isot,ib)) * - @ ( 1.d0/dble(ty(i))-1.d0/xtv0200 ) ) - xes = 1.0d0 - elseif (ib.eq.17) then - xlower = exp( dble(ee*elow(isot,ib)) * - @ ( 1.d0/dble(ty(i))-1.d0/xtv1000 ) ) - xes = 1.0d0 - elseif (ib.eq.20) then - xlower = exp( dble(ee*elow(isot,ib)) * - @ ( 1.d0/dble(ty(i))-1.d0/xtv0220 ) ) - xes = 1.0d0 - elseif (ib.eq.14) then - xlower = exp( dble(ee*nu12_1000) * - @ ( 1.d0/dble(ty(i))-1.d0/xtv1000 ) ) - xnu_trans = dble( nu(1,4)-nu12_1000 ) - xtv_trans = xnu_trans / dble(nu(1,4)/tvt1(i)- - @ nu12_1000/xtv1000) - xes = (1.d0-exp( dble(-ee*xnu_trans/xtv_trans) )) / - @ (1.d0-exp( dble(-ee*xnu_trans/ty(i)) )) - elseif (ib.eq.13) then - xlower = exp( dble(ee*nu12_0200) * - @ ( 1.d0/dble(ty(i))-1.d0/xtv0200 ) ) - xnu_trans = dble(nu(1,4)-nu12_0200) - xtv_trans = xnu_trans / dble(nu(1,4)/tvt1(i)- - @ nu12_0200/xtv0200) - xes = (1.d0-exp( dble(-ee*xnu_trans/xtv_trans) )) / - @ (1.d0-exp( dble(-ee*xnu_trans/ty(i)) )) - else - xlower = exp( dble(ee*elow(isot,ib)) * - @ ( 1.d0/dble(ty(i))-1.d0/tvt0(i) ) ) - xes = 1.0d0 - end if - xqv = (1.d0-exp( dble(-ee*667.3801/tvtbs(i)) )) / - @ (1.d0-exp( dble(-ee*667.3801/ty(i)) )) - xfactor = xlower * xqv**2.d0 * xes - - elseif (isot.eq.2) then - - xalfa = 1.d0/2.d0* exp( dble(-ee*(nu22_1000-nu(2,2))/ - @ ty(i)) ) - xbeta = 1.d0/2.d0* exp( dble(-ee*(nu22_0200-nu(2,2))/ - @ ty(i)) ) - xtv0200 = dble( - ee * nu22_0200 ) / - @ ( log( xbeta/(1.d0+xalfa+xbeta) ) - dble(ee*nu(2,2))/ - @ tvt0(i) ) - xtv1000 = dble( - ee * nu22_1000 ) / - @ ( log( xalfa/(1.d0+xalfa+xbeta) ) - dble(ee*nu(2,2))/ - @ tvt0(i) ) - - if (ib.eq.14) then - xlower = exp( dble(ee*nu22_1000) * - @ ( 1.d0/dble(ty(i))-1.d0/xtv1000 ) ) - xnu_trans = dble(nu(2,4)-nu22_1000) - xtv_trans = xnu_trans / dble(nu(2,4)/tvt1(i)-nu22_1000/ - @ xtv1000) - xes = (1.d0-exp( dble(-ee*xnu_trans/xtv_trans) )) / - @ (1.d0-exp( dble(-ee*xnu_trans/ty(i)) )) - elseif (ib.eq.13) then - xlower = exp( dble(ee*nu22_0200) * - @ ( 1.d0/dble(ty(i))-1.d0/xtv0200 ) ) - xnu_trans = dble( nu(2,4)-nu22_0200 ) - xtv_trans = xnu_trans / dble(nu(2,4)/tvt1(i)-nu22_0200/ - @ xtv0200) - xes = (1.d0-exp( dble(-ee*xnu_trans/xtv_trans) )) / - @ (1.d0-exp( dble(-ee*xnu_trans/ty(i)) )) - else - xlower = exp( dble(ee*elow(isot,ib)) * - @ ( 1.d0/dble(ty(i))-1.d0/tvt0(i) ) ) - xes = 1.0d0 - end if - xqv = (1.d0-exp( dble(-ee*662.3734/tvtbs(i)) )) / - @ (1.d0-exp( dble(-ee*662.3734/ty(i)) )) - xfactor = xlower * xqv**2.d0 * xes - - elseif (isot.eq.3) then - - xalfa = 1.d0/2.d0* exp( dble(-ee*(nu32_1000-nu(3,2))/ - @ ty(i)) ) - xbeta = 1.d0/2.d0* exp( dble(-ee*(nu32_0200-nu(3,2))/ - @ ty(i)) ) - xtv0200 = dble( - ee * nu32_0200 ) / - @ ( log( xbeta/(1.d0+xalfa+xbeta) ) - dble(ee*nu(3,2))/ - @ tvt0(i) ) - xtv1000 = dble( - ee * nu32_1000 ) / - @ ( log( xalfa/(1.d0+xalfa+xbeta) ) - dble(ee*nu(3,2))/ - @ tvt0(i) ) - - if (ib.eq.14) then - xlower = exp( dble(ee*nu32_1000) * - @ ( 1.d0/dble(ty(i))-1.d0/xtv1000 ) ) - xnu_trans = dble( nu(3,4)-nu32_1000 ) - xtv_trans = xnu_trans / dble(nu(3,4)/tvt1(i)-nu32_1000/ - @ xtv1000) - xes = (1.d0-exp( dble(-ee*xnu_trans/xtv_trans) )) / - @ (1.d0-exp( dble(-ee*xnu_trans/ty(i)) )) - elseif (ib.eq.13) then - xlower = exp( dble(ee*nu32_0200) * - @ ( 1.d0/dble(ty(i))-1.d0/xtv0200 ) ) - xnu_trans = dble( nu(3,4)-nu32_0200 ) - xtv_trans = xnu_trans / dble(nu(3,4)/tvt1(i)-nu32_0200/ - @ xtv0200) - xes = (1.d0-exp( dble(-ee*xnu_trans/xtv_trans) )) / - @ (1.d0-exp( dble(-ee*xnu_trans/ty(i)) )) - else - xlower = exp( dble(ee*elow(isot,ib)) * - @ ( 1.d0/dble(ty(i))-1.d0/tvt0(i) ) ) - xes = 1.0d0 - end if - xqv = (1.d0-exp( dble(-ee*648.4784/tvtbs(i)) )) / - @ (1.d0-exp( dble(-ee*648.4784/ty(i)) )) - xfactor = xlower * xqv**2.d0 * xes - - elseif (isot.eq.4) then - - xalfa = 1.d0/2.d0* exp( dble(-ee*(nu42_1000-nu(4,2))/ - @ ty(i)) ) - xbeta = 1.d0/2.d0* exp( dble(-ee*(nu42_0200-nu(4,2))/ - @ ty(i)) ) - xtv0200 = dble( - ee * nu42_0200 ) / - @ ( log( xbeta/(1.d0+xalfa+xbeta) ) - dble(ee*nu(4,2))/ - @ tvt0(i) ) - xtv1000 = dble( - ee * nu42_1000 ) / - @ ( log( xalfa/(1.d0+xalfa+xbeta) ) - dble(ee*nu(4,2))/ - @ tvt0(i) ) - - if (ib.eq.14) then - xlower = exp( dble(ee*nu42_1000) * - @ ( 1.d0/dble(ty(i))-1.d0/xtv1000 ) ) - xnu_trans = dble( nu(4,4)-nu42_1000 ) - xtv_trans = xnu_trans / dble(nu(4,4)/tvt1(i)-nu42_1000/ - @ xtv1000) - xes = (1.d0-exp( dble(-ee*xnu_trans/xtv_trans) )) / - @ (1.d0-exp( dble(-ee*xnu_trans/ty(i)) )) - elseif (ib.eq.13) then - xlower = exp( dble(ee*nu42_0200) * - $ ( 1.d0/dble(ty(i))-1.d0/xtv0200 ) ) - xnu_trans = dble( nu(4,4)-nu42_0200 ) - xtv_trans = xnu_trans / dble(nu(4,4)/tvt1(i)-nu42_0200/ - @ xtv0200) - xes = (1.d0-exp( dble(-ee*xnu_trans/xtv_trans) )) / - @ (1.d0-exp( dble(-ee*xnu_trans/ty(i)) )) - else - xlower = exp( dble(ee*elow(isot,ib)) * - @ ( 1.d0/dble(ty(i))-1.d0/tvt0(i) ) ) - xes = 1.0d0 - end if - xqv = (1.d0-exp( dble(-ee*664.7289/tvtbs(i)) )) / - @ (1.d0-exp( dble(-ee*664.7289/ty(i)) )) - xfactor = xlower * xqv**2.d0 * xes - - elseif (isot.eq.5 .and. ib.eq.1) then - - xlower = 1.d0 - xes = 1.0d0 - xqv = (1.d0-exp( dble(-ee*nuco_10/tvtbs(i)) )) / - @ (1.d0-exp( dble(-ee*nuco_10/ty(i)) )) - xfactor = xlower * xqv * xes - - end if - - con(i) = con(i) * xfactor - if (i.eq.nzy) coninf = coninf * xfactor - - end do - -! if ( isot.eq.1 .and. icurt_pop.eq.30 ) then -! close (30) -! endif - - return - end Index: trunk/LMDZ.MARS/libf/phymars/mztf_overlap.F =================================================================== --- trunk/LMDZ.MARS/libf/phymars/mztf_overlap.F (revision 496) +++ (revision ) @@ -1,774 +1,0 @@ -c*********************************************************************** -c mztf.f -c*********************************************************************** -c -c program for calculating atmospheric transmittances -c to be used in the calculation of curtis matrix coefficients - - subroutine mztf ( ig,cf,cfup,cfdw,vc,taugr, ib,isot, - @ iirw,iimu,itauout,icfout,itableout ) - -c i*out = 1 output of data -c i*out = 0 no output -c -c jul 2011 malv+fgg adapted to LMD-MGCM -c nov 98 mavl allow for overlaping in the lorentz line -c jan 98 malv version for mz1d. based on curtis/mztf.for -c 17-jul-96 mlp&crs change the calculation of mr. -c evitar: divide por cero. anhadiendo: ff -c oct-92 malv correct s(t) dependence for all histogr bands -c june-92 malv proper lower levels for laser bands -c may-92 malv new temperature dependence for laser bands -c @ 991 malv boxing for the averaged absorber amount and t -c ? malv extension up to 200 km altitude in mars -c 13-nov-86 mlp include the temperature weighted to match -c the eqw in the strong doppler limit. -c*********************************************************************** - - implicit none - - include 'nltedefs.h' - include 'nlte_atm.h' - include 'nlte_data.h' - include 'nlte_curtis.h' - include 'tcr_15um.h' - include 'nlte_results.h' - - -c arguments - integer ig !ADDED FOR TRACEBACK - real*8 cf(nl,nl), cfup(nl,nl), cfdw(nl,nl) ! o. - real*8 vc(nl), taugr(nl) ! o - integer ib ! i - integer isot ! i - integer iirw ! i - integer iimu ! i - integer itauout ! i - integer icfout ! i - integer itableout ! i - -c local variables and constants - integer i, in, ir, im, k ,j - integer nmu - parameter (nmu = 8) - real*8 tau(nl,nl) - real*8 tauinf(nl) - real*8 con(nzy), coninf - real*8 c1, c2 - real*8 t1, t2 - real*8 p1, p2 - real*8 mr1, mr2 - real*8 st1, st2 - real*8 c1box(70), c2box(70) - real*8 ff ! to avoid too small numbers - real*8 tvtbs(nzy) - real*8 st, beta, ts, eqwmu - real*8 mu(nmu), amu(nmu) - real*8 zld(nl), zyd(nzy) - real*8 correc - real deltanux ! width of vib-rot band (cm-1) -! character isotcode*2 - integer idummy - real*8 Desp,wsL - -c formats -! 111 format(a1) -! 112 format(a2) - 101 format(i1) - 202 format(i2) -! 180 format(a80) -! 181 format(a80) -c*********************************************************************** - -c some needed values -! rl=sqrt(log(2.d0)) -! pi2 = 3.14159265358989d0 - beta = 1.8d0 - idummy = 0 - Desp = 0.d0 - wsL = 0.d0 - -c esto es para que las subroutines de mztfsub calculen we -c de la forma apropiada para mztf, no para fot - icls=icls_mztf - -c codigos para filenames -! if (isot .eq. 1) isotcode = '26' -! if (isot .eq. 2) isotcode = '28' -! if (isot .eq. 3) isotcode = '36' -! if (isot .eq. 4) isotcode = '27' -! if (isot .eq. 5) isotcode = '62' -! if(ib.eq.1.or.ib.eq.2.or.ib.eq.3.or.ib.eq.4.or.ib.eq.5 -! @ .or.ib.eq.6.or.ib.eq.7.or.ib.eq.8.or.ib.eq.9) then -! write (ibcode1,101) ib -! else -! write (ibcode2,202) ib -! endif -! write (*,'( 30h calculating curtis matrix : ,2x, -! @ 8h band = ,i2,2x, 11h isotope = ,i2)') ib, isot - -c integration in angle !!!!!!!!!!!!!!!!!!!! - -c------- diffusivity approx. - if (iimu.eq.1) then -! write (*,*) ' diffusivity approx. beta = ',beta - mu(1) = 1.0d0 - amu(1)= 1.0d0 -c-------data for 8 points integration - elseif (iimu.eq.4) then - write (*,*)' 4 points for the gauss-legendre angle quadrature.' - mu(1)=(1.0d0+0.339981043584856)/2.0d0 - mu(2)=(1.0d0-0.339981043584856)/2.0d0 - mu(3)=(1.0d0+0.861136311594053)/2.0d0 - mu(4)=(1.0d0-0.861136311594053)/2.0d0 - amu(1)=0.652145154862546 - amu(2)=amu(1) - amu(3)=0.347854845137454 - amu(4)=amu(3) - beta=1.0d0 -c-------data for 8 points integration - elseif(iimu.eq.8) then - write (*,*)' 8 points for the gauss-legendre angle quadrature.' - mu(1)=(1.0d0+0.183434642495650)/2.0d0 - mu(2)=(1.0d0-0.183434642495650)/2.0d0 - mu(3)=(1.0d0+0.525532409916329)/2.0d0 - mu(4)=(1.0d0-0.525532409916329)/2.0d0 - mu(5)=(1.0d0+0.796666477413627)/2.0d0 - mu(6)=(1.0d0-0.796666477413627)/2.0d0 - mu(7)=(1.0d0+0.960289856497536)/2.0d0 - mu(8)=(1.0d0-0.960289856497536)/2.0d0 - amu(1)=0.362683783378362 - amu(2)=amu(1) - amu(3)=0.313706645877887 - amu(4)=amu(3) - amu(5)=0.222381034453374 - amu(6)=amu(5) - amu(7)=0.101228536290376 - amu(8)=amu(7) - beta=1.0d0 - end if -c!!!!!!!!!!!!!!!!!!!!!!! - -ccc -ccc determine abundances included in the absorber amount -ccc - -c first, set up the grid ready for interpolation. - do i=1,nzy - zyd(i) = dble(zy(i)) - enddo - do i=1,nl - zld(i) = dble(zl(i)) - enddo - - -c 2nd: correccion a la n10(i) (cantidad de absorbente en el lower state) -c por similitud a la que se hace en cza.for - - do i=1,nzy - if (isot.eq.5) then - con(i) = dble( coy(i) * imrco ) - else - con(i) = dble( co2y(i) * imr(isot) ) -c vibr. temp of the bending mode : - if (isot.eq.1) call interdp ( tvtbs,zyd,nzy, v626t1,zld,nl, 1 ) - if (isot.eq.2) call interdp ( tvtbs,zyd,nzy, v628t1,zld,nl, 1 ) - if (isot.eq.3) call interdp ( tvtbs,zyd,nzy, v636t1,zld,nl, 1 ) - if (isot.eq.4) call interdp ( tvtbs,zyd,nzy, v627t1,zld,nl, 1 ) - correc = 2.d0 * dexp( dble(-ee*elow(isot,2))/tvtbs(i) ) - con(i) = con(i) * ( 1.d0 - correc ) - endif -c----------------------------------------------------------------------- -c mlp & cristina. 17 july 1996 -c change the calculation of mr. it is used for calculating partial press -c alpha = alpha(self,co2)*pp +alpha(n2)*(pt-pp) -c for an isotope, if mr is obtained by co2*imr(iso)/nt we are considerin -c collisions with other co2 isotopes (including the major one, 626) -c as if they were with n2. assuming mr as co2/nt, we consider collisions -c of type 628-626 as of 626-626 instead of as 626-n2. -c mrx(i)=con(i)/ntx(i) ! old malv - -! mrx(i)= dble(co2x(i)/ntx(i)) ! mlp & crs - -c jan 98: -c esta modif de mlp implica anular el correc (deberia revisar esto) - mr(i) = dble(co2y(i)/nty(i)) ! malv, jan 98 - -c----------------------------------------------------------------------- - - end do - -! como beta y 1.d5 son comunes a todas las weighted absorber amounts, -! los simplificamos: -! coninf = beta * 1.d5 * dble( con(n) / log( con(n-1) / con(n) ) ) - coninf = dble( con(nzy) / log( con(nzy-1) / con(nzy) ) ) - -! write (*,*) ' coninf =', coninf - -ccc -ccc temp dependence of the band strength and -ccc nlte correction factor for the absorber amount -ccc - call mztf_correccion ( coninf, con, ib, isot, itableout ) - -ccc -ccc reads histogrammed spectral data (strength for lte and vmr=1) -ccc - !hfile1 = dirspec//'hi'//dn ! ya no distinguimos entre d/n -!! hfile1 = dirspec//'hid' ! (see why in his.for) -! hfile='hid' -!! if (ib.eq.13 .or. ib.eq.14 ) hfile1 = dirspec//'his' -! if (ib.eq.13 .or. ib.eq.14 ) hfile1 = 'his' -! -! if(ib.eq.1.or.ib.eq.2.or.ib.eq.3.or.ib.eq.4.or.ib.eq.5 -! @ .or.ib.eq.6.or.ib.eq.7.or.ib.eq.8.or.ib.eq.9) then -! if (isot.eq.1) hisfile = hfile1//'26-'//ibcode1//'.dat' -! if (isot.eq.2) hisfile = hfile1//'28-'//ibcode1//'.dat' -! if (isot.eq.3) hisfile = hfile1//'36-'//ibcode1//'.dat' -! if (isot.eq.4) hisfile = hfile1//'27-'//ibcode1//'.dat' -! if (isot.eq.5) hisfile = hfile1//'62-'//ibcode1//'.dat' -! else -! if (isot.eq.1) hisfile = hfile1//'26-'//ibcode2//'.dat' -! if (isot.eq.2) hisfile = hfile1//'28-'//ibcode2//'.dat' -! if (isot.eq.3) hisfile = hfile1//'36-'//ibcode2//'.dat' -! if (isot.eq.4) hisfile = hfile1//'27-'//ibcode2//'.dat' -! if (isot.eq.5) hisfile = hfile1//'62-'//ibcode2//'.dat' -! endif -! write (*,*) 'hisfile: ', hisfile - -! the argument to rhist is to make this compatible with mztf_comp.f, -! which is a useful modification of mztf.f (to change strengths of bands -! call rhist (1.0) - if(ib.eq.1) then - if(isot.eq.1) then !Case 1 - mm=mm_c1 - nbox=nbox_c1 - tmin=tmin_c1 - tmax=tmax_c1 - do i=1,nbox_max - no(i)=no_c1(i) - dist(i)=dist_c1(i) - do j=1,nhist - sk1(j,i)=sk1_c1(j,i) - xls1(j,i)=xls1_c1(j,i) - xln1(j,i)=xln1_c1(j,i) - xld1(j,i)=xld1_c1(j,i) - enddo - enddo - do j=1,nhist - thist(j)=thist_c1(j) - enddo - else if(isot.eq.2) then !Case 2 - mm=mm_c2 - nbox=nbox_c2 - tmin=tmin_c2 - tmax=tmax_c2 - do i=1,nbox_max - no(i)=no_c2(i) - dist(i)=dist_c2(i) - do j=1,nhist - sk1(j,i)=sk1_c2(j,i) - xls1(j,i)=xls1_c2(j,i) - xln1(j,i)=xln1_c2(j,i) - xld1(j,i)=xld1_c2(j,i) - enddo - enddo - do j=1,nhist - thist(j)=thist_c2(j) - enddo - else if(isot.eq.3) then !Case 3 - mm=mm_c3 - nbox=nbox_c3 - tmin=tmin_c3 - tmax=tmax_c3 - do i=1,nbox_max - no(i)=no_c3(i) - dist(i)=dist_c3(i) - do j=1,nhist - sk1(j,i)=sk1_c3(j,i) - xls1(j,i)=xls1_c3(j,i) - xln1(j,i)=xln1_c3(j,i) - xld1(j,i)=xld1_c3(j,i) - enddo - enddo - do j=1,nhist - thist(j)=thist_c3(j) - enddo - else if(isot.eq.4) then !Case 4 - mm=mm_c4 - nbox=nbox_c4 - tmin=tmin_c4 - tmax=tmax_c4 - do i=1,nbox_max - no(i)=no_c4(i) - dist(i)=dist_c4(i) - do j=1,nhist - sk1(j,i)=sk1_c4(j,i) - xls1(j,i)=xls1_c4(j,i) - xln1(j,i)=xln1_c4(j,i) - xld1(j,i)=xld1_c4(j,i) - enddo - enddo - do j=1,nhist - thist(j)=thist_c4(j) - enddo - else - write(*,*)'isot must be 2,3 or 4 for ib=1!!' - write(*,*)'stop at mztf_overlap/317' - stop - endif - else if (ib.eq.2) then - if(isot.eq.1) then !Case 5 - mm=mm_c5 - nbox=nbox_c5 - tmin=tmin_c5 - tmax=tmax_c5 - do i=1,nbox_max - no(i)=no_c5(i) - dist(i)=dist_c5(i) - do j=1,nhist - sk1(j,i)=sk1_c5(j,i) - xls1(j,i)=xls1_c5(j,i) - xln1(j,i)=xln1_c5(j,i) - xld1(j,i)=xld1_c5(j,i) - enddo - enddo - do j=1,nhist - thist(j)=thist_c5(j) - enddo - else - write(*,*)'isot must be 1 for ib=2!!' - write(*,*)'stop at mztf_overlap/341' - stop - endif - else if (ib.eq.3) then - if(isot.eq.1) then !Case 6 - mm=mm_c6 - nbox=nbox_c6 - tmin=tmin_c6 - tmax=tmax_c6 - do i=1,nbox_max - no(i)=no_c6(i) - dist(i)=dist_c6(i) - do j=1,nhist - sk1(j,i)=sk1_c6(j,i) - xls1(j,i)=xls1_c6(j,i) - xln1(j,i)=xln1_c6(j,i) - xld1(j,i)=xld1_c6(j,i) - enddo - enddo - do j=1,nhist - thist(j)=thist_c6(j) - enddo - else - write(*,*)'isot must be 1 for ib=3!!' - write(*,*)'stop at mztf_overlap/365' - stop - endif - else if (ib.eq.4) then - if(isot.eq.1) then !Case 7 - mm=mm_c7 - nbox=nbox_c7 - tmin=tmin_c7 - tmax=tmax_c7 - do i=1,nbox_max - no(i)=no_c7(i) - dist(i)=dist_c7(i) - do j=1,nhist - sk1(j,i)=sk1_c7(j,i) - xls1(j,i)=xls1_c7(j,i) - xln1(j,i)=xln1_c7(j,i) - xld1(j,i)=xld1_c7(j,i) - enddo - enddo - do j=1,nhist - thist(j)=thist_c7(j) - enddo - else - write(*,*)'isot must be 1 for ib=4!!' - write(*,*)'stop at mztf_overlap/389' - stop - endif - else - write(*,*)'ib must be 1,2,3 or 4!!' - write(*,*)'stop at mztf_overlap/394' - endif - - if (isot.ne.5) deltanux = deltanu(isot,ib) - if (isot.eq.5) deltanux = deltanuco - -c****** -c****** calculation of tauinf(nl) -c****** - call initial - - ff=1.0e10 - - do i=nl,1,-1 - - if(i.eq.nl)then - - call intz (zl(i),c2,p2,mr2,t2, con) - do kr=1,nbox - ta(kr)=t2 - end do -! write (*,*) ' i, t2 =', i, t2 - call interstrength (st2,t2,ka,ta) - aa = p2 * coninf * mr2 * (st2 * ff) - bb = p2 * coninf * st2 - cc = coninf * st2 - dd = t2 * coninf * st2 - do kr=1,nbox - ccbox(kr) = coninf * ka(kr) - ddbox(kr) = t2 * ccbox(kr) -! c2box(kr) = c2 * ka(kr) * beta * dble(deltaz) * 1.d5 - c2box(kr) = c2 * ka(kr) * dble(deltaz) - end do -! c2 = c2 * st2 * beta * dble(deltaz) * 1.d5 - c2 = c2 * st2 * dble(deltaz) - - else - call intz (zl(i),c1,p1,mr1,t1, con) - do kr=1,nbox - ta(kr)=t1 - end do -! write (*,*) ' i, t1 =', i, t1 - call interstrength (st1,t1,ka,ta) - do kr=1,nbox -! c1box(kr) = c1 * ka(kr) * beta * dble(deltaz) * 1.d5 - c1box(kr) = c1 * ka(kr) * dble(deltaz) - end do -! c1 = c1 * st1 * beta * dble(deltaz) * 1.d5 - c1 = c1 * st1 * dble(deltaz) - aa = aa + ( p1*mr1*(c1*ff) + p2*mr2*(c2*ff)) / 2.d0 - bb = bb + ( p1*c1 + p2*c2 ) / 2.d0 - cc = cc + ( c1 + c2 ) / 2.d0 - dd = dd + ( t1*c1 + t2*c2 ) / 2.d0 - do kr=1,nbox - ccbox(kr) = ccbox(kr) + ( c1box(kr) + c2box(kr) )/2.d0 - ddbox(kr) = ddbox(kr) + ( t1*c1box(kr)+t2*c2box(kr) )/2.d0 - end do - - mr2 = mr1 - c2=c1 - do kr=1,nbox - c2box(kr) = c1box(kr) - end do - t2=t1 - p2=p1 - end if - - pt = bb / cc - pp = aa / (cc*ff) - -! ta=dd/cc -! tdop = ta - ts = dd/cc - do kr=1,nbox - ta(kr) = ddbox(kr) / ccbox(kr) - end do -! write (*,*) ' i, ts =', i, ts - call interstrength(st,ts,ka,ta) -! call intershape(alsa,alna,alda,tdop) - call intershape(alsa,alna,alda,ta) - -* ua = cc/st - -c next loop calculates the eqw for an especified path ua,pp,pt,ta - - eqwmu = 0.0d0 - do im = 1,iimu - eqw=0.0d0 - do kr=1,nbox - ua(kr) = ccbox(kr) / ka(kr) * beta * 1.0d5 / mu(im) - if(ua(kr).lt.0.)write(*,*)'mztf_overlap/483',ua(kr), - $ ccbox(kr),ka(kr),beta,mu(im),kr,im,i,nl - - call findw(ig,iirw, idummy,c1,p1,Desp,wsL) - if ( i_supersat .eq. 0 ) then - eqw=eqw+no(kr)*w - else - eqw = w + (no(kr)-1) * ( asat_box*dist(kr) ) - endif - end do - eqwmu = eqwmu + eqw * mu(im)*amu(im) - end do - - tauinf(i) = exp( - eqwmu / dble(deltanux) ) - - end do ! i continue - -! if ( isot.eq.1 .and. ib.eq.2 ) then -! write (*,*) ' tauinf(nl) = ', tauinf(nl) -! write (*,*) ' tauinf(1) = ', tauinf(1) -! endif - -c****** -c****** calculation of tau(in,ir) for n<=r -c****** - - do 1 in=1,nl-1 - - call initial - call intz (zl(in), c1,p1,mr1,t1, con) - do kr=1,nbox - ta(kr) = t1 - end do - call interstrength (st1,t1,ka,ta) - do kr=1,nbox -! c1box(kr) = c1 * ka(kr) * beta * dble(deltaz) * 1.d5 - c1box(kr) = c1 * ka(kr) * dble(deltaz) - end do -! c1 = c1 * st1 * beta * dble(deltaz) * 1.d5 - c1 = c1 * st1 * dble(deltaz) - - do 2 ir=in,nl-1 - - if (ir.eq.in) then - tau(in,ir) = 1.d0 - goto 2 - end if - - call intz (zl(ir), c2,p2,mr2,t2, con) - do kr=1,nbox - ta(kr) = t2 - end do - call interstrength (st2,t2,ka,ta) - do kr=1,nbox -! c2box(kr) = c2 * ka(kr) * beta * dble(deltaz) * 1.d5 - c2box(kr) = c2 * ka(kr) * dble(deltaz) - end do -! c2 = c2 * st2 * beta * dble(deltaz) * 1.e5 - c2 = c2 * st2 * dble(deltaz) - -c aa = aa + ( p1*mr1*c1 + p2*mr2*c2 ) / 2.d0 - aa = aa + ( p1*mr1*(c1*ff) + p2*mr2*(c2*ff)) / 2.d0 - bb = bb + ( p1*c1 + p2*c2 ) / 2.d0 - cc = cc + ( c1 + c2 ) / 2.d0 - dd = dd + ( t1*c1 + t2*c2 ) / 2.d0 - do kr=1,nbox - ccbox(kr) = ccbox(kr) + ( c1box(kr) + c2box(kr) ) /2.d0 - ddbox(kr) = ddbox(kr) + ( t1*c1box(kr) + t2*c2box(kr) ) /2.d0 - end do - - mr1=mr2 - t1=t2 - c1=c2 - p1=p2 - do kr=1,nbox - c1box(kr) = c2box(kr) - end do - - pt = bb / cc - pp = aa / (cc * ff) - -* ta=dd/cc -* tdop = ta - ts = dd/cc - do kr=1,nbox - ta(kr) = ddbox(kr) / ccbox(kr) - end do - call interstrength(st,ts,ka,ta) - call intershape(alsa,alna,alda,ta) -* ua = cc/st - -c next loop calculates the eqw for an especified path ua,pp,pt,ta - - eqwmu = 0.0d0 - do im = 1,iimu - eqw=0.0d0 - do kr=1,nbox - ua(kr) = ccbox(kr) / ka(kr) * beta * 1.0d5 / mu(im) - if(ua(kr).lt.0.)write(*,*)'mztf_overlap/581',ua(kr), - $ ccbox(kr),ka(kr),beta,mu(im),kr,im,i,nl - - call findw(ig,iirw, idummy,c1,p1,Desp,wsL) - if ( i_supersat .eq. 0 ) then - eqw=eqw+no(kr)*w - else - eqw = w + (no(kr)-1) * ( asat_box*dist(kr) ) - endif - end do - eqwmu = eqwmu + eqw * mu(im)*amu(im) - end do - - tau(in,ir) = exp( - eqwmu / dble(deltanux) ) - - 2 continue - - 1 continue - -! if ( isot.eq.1 .and. ib.eq.2 ) then -! write (*,*) ' tau(1,*) , *=1,20 ' -! write (*,*) ( sngl(tau(1,k)), k=1,20 ) -! endif - - -c********** -c********** calculation of tau(in,ir) for n>r -c********** - - in=nl - - call initial - call intz (zl(in), c1,p1,mr1,t1, con) - do kr=1,nbox - ta(kr) = t1 - end do - call interstrength (st1,t1,ka,ta) - do kr=1,nbox -! c1box(kr) = c1 * ka(kr) * beta * dble(deltaz) * 1.d5 - c1box(kr) = c1 * ka(kr) * dble(deltaz) - end do -! c1 = c1 * st1 * beta * dble(deltaz) * 1.d5 - c1 = c1 * st1 * dble(deltaz) - - do 4 ir=in-1,1,-1 - - call intz (zl(ir), c2,p2,mr2,t2, con) - do kr=1,nbox - ta(kr) = t2 - end do - call interstrength (st2,t2,ka,ta) - do kr=1,nbox -! c2box(kr) = c2 * ka(kr) * beta * dble(deltaz) * 1.d5 - c2box(kr) = c2 * ka(kr) * dble(deltaz) - end do -! c2 = c2 * st2 * beta * dble(deltaz) * 1.d5 - c2 = c2 * st2 * dble(deltaz) - - aa = aa + ( p1*mr1*(c1*ff) + p2*mr2*(c2*ff)) / 2.d0 - bb = bb + ( p1*c1 + p2*c2 ) / 2.d0 - cc = cc + ( c1 + c2 ) / 2.d0 - dd = dd + ( t1*c1 + t2*c2 ) / 2.d0 - do kr=1,nbox - ccbox(kr) = ccbox(kr) + ( c1box(kr) + c2box(kr) ) /2.d0 - ddbox(kr) = ddbox(kr) + ( t1*c1box(kr) + t2*c2box(kr) ) /2.d0 - end do - - mr1=mr2 - c1=c2 - t1=t2 - p1=p2 - do kr=1,nbox - c1box(kr) = c2box(kr) - end do - - pt = bb / cc - pp = aa / (cc * ff) - ts = dd / cc - do kr=1,nbox - ta(kr) = ddbox(kr) / ccbox(kr) - end do - call interstrength (st,ts,ka,ta) - call intershape (alsa,alna,alda,ta) - -* ua = cc/st - -c next loop calculates the eqw for an especified path ua,pp,pt,ta - - eqwmu = 0.0d0 - do im = 1,iimu - eqw=0.0d0 - do kr=1,nbox - ua(kr) = ccbox(kr) / ka(kr) * beta * 1.0d5 / mu(im) - if(ua(kr).lt.0.)write(*,*)'mztf_overlap/674',ua(kr), - $ ccbox(kr),ka(kr),beta,mu(im),kr,im,i,nl - - call findw(ig,iirw, idummy,c1,p1,Desp,wsL) - if ( i_supersat .eq. 0 ) then - eqw=eqw+no(kr)*w - else - eqw = w + (no(kr)-1) * ( asat_box*dist(kr) ) - endif - end do - eqwmu = eqwmu + eqw * mu(im)*amu(im) - end do - - tau(in,ir) = exp( - eqwmu / dble(deltanux) ) - - 4 continue - -c -c due to the simmetry of the transmittances -c - do in=nl-1,2,-1 - do ir=in-1,1,-1 - tau(in,ir) = tau(ir,in) - end do - end do - - -ccc -ccc writing out transmittances -ccc - if (itauout.eq.1) then - -! if(ib.eq.1.or.ib.eq.2.or.ib.eq.3.or.ib.eq.4.or.ib.eq.5 -! @ .or.ib.eq.6.or.ib.eq.7.or.ib.eq.8.or.ib.eq.9) then -! open( 1, file= -! @ dircurtis//'taul'//isotcode//dn//ibcode1//'.dat', -! @ access='sequential', form='unformatted' ) -! else -! open( 1, file= -! @ dircurtis//'taul'//isotcode//dn//ibcode2//'.dat', -! @ access='sequential', form='unformatted' ) -! endif - -! write(1) dummy -! write(1)' format: (tauinf(n),(tau(n,r),r=1,nl),n=1,nl)' -! do in=1,nl -! write (1) tauinf(in), ( tau(in,ir), ir=1,nl ) -! end do -! close(unit=1) - - elseif (itauout.eq.2) then - -! if(ib.eq.1.or.ib.eq.2.or.ib.eq.3.or.ib.eq.4.or.ib.eq.5 -! @ .or.ib.eq.6.or.ib.eq.7.or.ib.eq.8.or.ib.eq.9) then -! open( 1, file= -! @ dircurtis//'taul'//isotcode//dn//ibcode1//'.dat') -! else -! open( 1, file= -! @ dircurtis//'taul'//isotcode//dn//ibcode2//'.dat') -! endif - -! !write(1,*) dummy -! !write(1,*) 'tij for curtis matrix calculations ' -! !write(1,*)' cira mars model atmosphere ' -! write(1,*)' beta= ',beta,'deltanu= ',deltanux -! write(1,*)' number of elements (in,ir)= ',nl,nl -! write(1,*)' format: (tauinf(in),(tau(in,ir),ir=1,nl),in=1,nl)' - -! do in=1,nl -! write (1,*) tauinf(in) -! do ir=1,nl -! write(1,*) tau(in,ir) -! end do -! end do -! close(unit=1) - -! if(ib.eq.1.or.ib.eq.2.or.ib.eq.3.or.ib.eq.4.or.ib.eq.5 -! @ .or.ib.eq.6.or.ib.eq.7.or.ib.eq.8.or.ib.eq.9) then -! write (*,'(1x, 31htransmitances written out in: ,a22)') -! @ 'taul'//isotcode//dn//ibcode1 -! else -! write (*,'(1x, 31htransmitances written out in: ,a22)') -! @ 'taul'//isotcode//dn//ibcode2 -! endif - - end if - -c cleaning of transmittances -! call elimin_tau(tau,tauinf,nl,nan,itableout,nw,dummy, -! @ isotcode,dn,ibcode2) - -c construction of the curtis matrix - - call mzcf ( tauinf,tau, cf,cfup,cfdw, vc,taugr, - @ ib,isot,icfout,itableout ) - - -c end - return - end Index: trunk/LMDZ.MARS/libf/phymars/mztfsub_overlap.F =================================================================== --- trunk/LMDZ.MARS/libf/phymars/mztfsub_overlap.F (revision 496) +++ (revision ) @@ -1,947 +1,0 @@ -c*********************************************************************** -c File with all subroutines required by mztf -c -c jan 98 malv basado en mztfsub_solar -c jul 2011 malv+fgg adapted to LMD-MGCM -c -c contiene: -c initial -c intershape -c interstrength -c intz -c rhist -c interh -c we -c simrul -c fi -c f -c findw -c voigtf -c*********************************************************************** - -c **************************************************************** - subroutine initial - -c ma & crs !evita troubles 16-july-96 -c **************************************************************** - - implicit none - - include 'nltedefs.h' - include 'nlte_curtis.h' - -c local variables - integer i - -c *************** - - eqw = 0.0d00 - aa = 0.0d00 - bb = 0.0d00 - cc = 0.0d00 - dd = 0.0d00 - - do i=1,nbox - ua(i) = 0.0d0 - ccbox(i) = 0.0d0 - ddbox(i) = 0.0d0 - end do - - return - end - -c ********************************************************************** - subroutine intershape(alsx,alnx,adx,xtemp) -c interpolates the line shape parameters at a temperature xtemp from -c input histogram data. -c ********************************************************************** - - implicit none - - include 'nltedefs.h' - include 'nlte_curtis.h' - -c arguments - real*8 alsx(nbox_max),alnx(nbox_max),adx(nbox_max),xtemp(nbox_max) - -c local variables - integer i, k - -c *********** - -! write (*,*) 'intershape xtemp =', xtemp - - do 1, k=1,nbox - if (xtemp(k).gt.tmax) then - write (*,*) ' WARNING ! Tpath,tmax= ',xtemp(k),tmax - xtemp(k) = tmax - endif - if (xtemp(k).lt.tmin) then - write (*,*) ' WARNING ! Tpath,tmin= ',xtemp(k),tmin - xtemp(k) = tmin - endif - - i = 1 - do while (i.le.mm) - i = i + 1 - - if (abs(xtemp(k)-thist(i)) .lt. 1.0d-4) then !evita troubles - alsx(k)=xls1(i,k) !16-july-1996 - alnx(k)=xln1(i,k) - adx(k)=xld1(i,k) - goto 1 - elseif ( thist(i) .le. xtemp(k) ) then - alsx(k) = (( xls1(i,k)*(thist(i-1)-xtemp(k)) + - @ xls1(i-1,k)*(xtemp(k)-thist(i)) )) / (thist(i-1)-thist(i)) - alnx(k) = (( xln1(i,k)*(thist(i-1)-xtemp(k)) + - @ xln1(i-1,k)*(xtemp(k)-thist(i)) )) / (thist(i-1)-thist(i)) - adx(k) = (( xld1(i,k)*(thist(i-1)-xtemp(k)) + - @ xld1(i-1,k)*(xtemp(k)-thist(i)) )) / (thist(i-1)-thist(i)) - goto 1 - end if - end do - write (*,*) - @ ' error in xtemp(k). it should be between tmin and tmax' -1 continue - - return - end -c ********************************************************************** - subroutine interstrength (stx, ts, sx, xtemp) -c interpolates the line strength at a temperature xtemp from -c input histogram data. -c ********************************************************************** - - implicit none - - include 'nltedefs.h' - include 'nlte_curtis.h' - -c arguments - real*8 stx ! output, total band strength - real*8 ts ! input, temp for stx - real*8 sx(nbox_max) ! output, strength for each box - real*8 xtemp(nbox_max) ! input, temp for sx - -c local variables - integer i, k - -c *********** - - do 1, k=1,nbox -! if(xtemp(k).lt.ts)then -! write(*,*)'***********************' -! write(*,*)'mztfsub_overlap/EEEEEEH!',xtemp(k),ts,k -! write(*,*)'***********************' -! endif - if (xtemp(k).gt.tmax) xtemp(k) = tmax - if (xtemp(k).lt.tmin) xtemp(k) = tmin - i = 1 - do while (i.le.mm-1) - i = i + 1 -! write(*,*)'mztfsub_overlap/136',i,xtemp(k),thist(i) - if ( abs(xtemp(k)-thist(i)) .lt. 1.0d-4 ) then - sx(k) = sk1(i,k) -! write(*,*)'mztfsub_overlap/139',sx(k),k,i - goto 1 - elseif ( thist(i) .le. xtemp(k) ) then - sx(k) = ( sk1(i,k)*(thist(i-1)-xtemp(k)) + sk1(i-1,k)* - @ (xtemp(k)-thist(i)) ) / (thist(i-1)-thist(i)) -! write(*,*)'mztfsub_overlap/144',sx(k),k,i - goto 1 - end if - end do - write (*,*) ' error in xtemp(kr) =', xtemp(k), - @ '. it should be between ' - write (*,*) ' tmin =',tmin, ' and tmax =',tmax - stop -1 continue - - stx = 0.d0 - if (ts.gt.tmax) ts = dble( tmax ) - if (ts.lt.tmin) ts = dble( tmin ) - i = 1 - do while (i.le.mm-1) - i = i + 1 -! write(*,*)'mztfsub_overlap/160',i,ts,thist(i) - if ( abs(ts-thist(i)) .lt. 1.0d-4 ) then - do k=1,nbox - stx = stx + no(k) * sk1(i,k) -! write(*,*)'mztfsub_overlap/164',stx - end do - return - elseif ( thist(i) .le. ts ) then - do k=1,nbox - stx = stx + no(k) * (( sk1(i,k)*(thist(i-1)-ts) + - @ sk1(i-1,k)*(ts-thist(i)) )) / (thist(i-1)-thist(i)) -! write(*,*)'mztfsub_overlap/171',stx - end do -! stop - return - end if - end do - - return - end -c ********************************************************************** - subroutine intz(h,aco2,ap,amr,at, con) -c return interp. concentration, pressure,mixing ratio and temperature -c for a input height h -c ********************************************************************** - - implicit none - include 'nltedefs.h' - include 'nlte_atm.h' - include 'nlte_curtis.h' - -c arguments - real h ! i - real*8 con(nzy) ! i - real*8 aco2, ap, at, amr ! o - -c local variables - integer k - -c ************ - - if ( ( h.lt.zy(1) ).and.( h.le.-1.e-5 ) ) then - write (*,*) ' zp= ',h,' zy(1)= ',zy(1) - stop'from intz: error in interpolation, z < minimum height' - elseif (h.gt.zy(nzy)) then - write (*,*) ' zp= ',h,' zy(nzy)= ',zy(nzy) - stop'from intz: error in interpolation, z > maximum height' - end if - - if (h.eq.zy(nzy)) then - ap = dble( py(nzy) ) - aco2= con(nzy) - at = dble( ty(nzy) ) - amr = dble( mr(nzy) ) - return - end if - - do k=1,nzy-1 - if( abs( h-zy(k) ).le.( 1.e-5 ) ) then - ap = dble( py(k) ) - aco2= con(k) - at = dble( ty(k) ) - amr = dble( mr(k) ) - return - elseif(h.gt.zy(k).and.h.lt.zy(k+1))then - ap = dble( exp( log(py(k)) + log(py(k+1)/py(k)) * - @ (h-zy(k)) / (zy(k+1)-zy(k)) ) ) - aco2 = exp( log(con(k)) + log( con(k+1)/con(k) ) * - @ (h-zy(k)) / (zy(k+1)-zy(k)) ) - at = dble( ty(k)+(ty(k+1)-ty(k))*(h-zy(k))/ - @ (zy(k+1)-zy(k)) ) - amr = dble( mr(k)+(mr(k+1)-mr(k))*(h-zy(k))/ - @ (zy(k+1)-zy(k)) ) - return - end if - end do - - return - end - -c ******************************************************************* - - subroutine rhist (factor_comp) - -c reads histogram data arrays created by ~/spectral/his.for -c malv nov-98 add average distance between lines for overlapp - -c ******************************************************************* - - - implicit none - - include 'nltedefs.h' - include 'nlte_curtis.h' - include 'datafile.h' - -c arguments - real factor_comp - -c local variables - integer j, r - real*8 sk1_aux, xls1_aux, xln1_aux, xld1_aux,weight,nu0 - character tonto*50 - -c formats -! 100 format(80a1) ! Esto es si fuese byte dummy(80) - 100 format(a80) ! Esto es si fuese character dummy*80 - 150 format(a50) ! Esto es si fuese character dummy*80 - -c *************** - - open(unit=3, - $ file=trim(datafile)//'/NLTEDAT/' - $ //hisfile(1:len_trim(hisfile)),status='old') - !read(3,100) dummy - read(3,150) tonto - read(3,*) weight - read(3,*) mm - read(3,*) nu0 - read(3,*) nbox - !read(3,'(a)') dumm - read(3,'(a)') tonto - - if ( nbox .gt. nbox_max ) then - write (*,*) ' nbox too large in input file ', hisfile - stop ' Check maximum number nbox_max in mz1d.par ' - endif - do 1 j=1,mm ! for each temperature - read(3,*) thist(j) - do r=1,nbox ! for each box - read(3,*) no(r), sk1(j,r), xls1(j,r),xln1(j,r),xld1(j,r), - @ dist(r) -c xld1(j,r)=xld1(j,r)*0.83255 !0.83255=sqrt(log(2)) - enddo - 1 continue - tmax=thist(1) - tmin=thist(mm) - - !close(unit=3,dispose='save') - close(unit=3) - - - do 2 j=1,mm - do r=1,nbox - sk1(j,r) = sk1(j,r) * factor_comp - enddo -2 continue - - - return - end - -c **************************************************************** - subroutine interh( sx, alsx, alnx, adx, xtemp, xtdop ) - -c interpolates a histogram at temperature xtemp from input histogr - -c jan 98 malv version para mz1d basada en el inth de solar10: -c mz5/curtis/mztfsub_solar.f -c **************************************************************** - - implicit none - - include 'nltedefs.h' - include 'nlte_curtis.h' - -c arguments - real*8 sx(nbox_max) ! o - real*8 xtemp ! i - real*8 alsx(nbox_max) ! o - real*8 alnx(nbox_max) ! o - real*8 adx(nbox_max) ! o - real*8 xtdop ! i - -c local variables - integer i, j, k - -c ************ - - - if (xtemp.gt.thist(1)) then -! write (*,*) ' xtemp-path, thist(1)max: ', -! @ xtemp,thist(1) - xtemp = thist(1) - elseif (xtemp.lt.thist(nhist)) then -! write (*,*) ' xtemp-path, thist(nhist)min: ', -! @ xtemp,thist(nhist) - xtemp = thist(nhist) - end if - - i=0 -1 i=i+1 - if (abs(xtemp-thist(i)) .lt. 1.0d-4) goto 2 - if (thist(i).lt.xtemp) goto 2 - goto 1 -2 j=i - -! write (*,*) 'InterH/ j, xtemp, th(1),th(nh)', -! @ j, xtemp, thist(1),thist(nhist) - - if (j.gt.1) then - do k=1,nbox - sx(k) = ( sk1(j,k) * (thist(j-1)-xtemp) + sk1(j-1,k) * - @ (xtemp-thist(j)) ) / (thist(j-1)-thist(j)) - enddo - elseif (j.eq.1) then - do k=1,nbox - sx(k) = sk1(1,k) - enddo - endif - - if (xtdop.gt.thist(1)) then -! write (*,*) ' xtdop-path, thist(1)max: ', -! @ xtdop,thist(1) - xtdop = thist(1) - elseif (xtdop.lt.thist(nhist)) then -! write (*,*) ' xtdop-path, thist(nhist)min: ', -! @ xtdop,thist(nhist) - xtdop = thist(nhist) - end if - - i=0 -4 i=i+1 - if (abs(xtdop-thist(i)) .lt. 1.0d-4) goto 5 - if (thist(i).lt.xtdop) goto 5 - goto 4 -5 j=i - -! write (*,*) 'InterH/ j, xtdop', -! @ j, xtdop - - if (j.gt.1) then - do k=1,nbox - alsx(k) = ( xls1(j,k) * (thist(j-1)-xtdop) + xls1(j-1,k)* - @ (xtdop-thist(j)) ) / (thist(j-1)-thist(j)) - alnx(k) = ( xln1(j,k) * (thist(j-1)-xtdop) + xln1(j-1,k)* - @ (xtdop-thist(j)) ) / (thist(j-1)-thist(j)) - adx(k) = ( xld1(j,k) * (thist(j-1)-xtdop) + xld1(j-1,k)* - @ (xtdop-thist(j)) ) / (thist(j-1)-thist(j)) - enddo - elseif (j.eq.1) then - do k=1,nbox - alsx(k) = xls1(1,k) - alnx(k) = xln1(1,k) - adx(k) = xld1(j,k) - enddo - endif - -c end - return - end - -c ********************************************************************** - real*8 function we(ig,me,pe,pl, idummy, nt_local,p_local, Desp, wsL) -c icls=5 -->para mztf -c icls=1,2,3-->para fot, line shape (v=1,l=2,d=3) (only use if wr=2) -c calculates an approximate equivalent width for an error estimate. -c -c ioverlap = 0 ....... no correction for overlaping -c 1 ....... "lisat" first correction (see overlap_box. -c 2 ....... " " " plus "supersaturation" - -c idummy=0 do nothing -c 1 write out some values for diagnostics -c 2 correct the Strong Lorentz behaviour for SZA>90 -c 3 casos 1 & 2 - -c malv nov-98 add overlaping's corrections -c ********************************************************************** - - implicit none - - include 'nltedefs.h' - include 'nlte_curtis.h' - include 'tcr_15um.h' - -c arguments - integer ig ! ADDED FOR TRACEBACK - real*8 me ! I. path's absorber amount - real*8 pe ! I. path's presion total - real*8 pl ! I. path's partial pressure of CO2 - real*8 nt_local ! I. needed for strong limit of Lorentz profil - real*8 p_local ! I. " " " - integer idummy ! I. indica varias opciones - real*8 wsL ! O. need this for strong Lorentz correction - real*8 Desp ! I. need this for strong Lorentz correction - -c local variables - integer i - real*8 y,x,wl,wd - real*8 cn(0:7),dn(0:7) - real*8 pi, xx - real*8 f_sat_box - real*8 dv_sat_box, dv_corte_box - real*8 area_core_box, area_wing_box - real*8 wlgood , parentesis , xlor - real*8 wsl_grad - - -c data blocks - data cn/9.99998291698d-1,-3.53508187098d-1,9.60267807976d-2, - @ -2.04969011013d-2,3.43927368627d-3,-4.27593051557d-4, - @ 3.42209457833d-5,-1.28380804108d-6/ - data dn/1.99999898289,5.774919878d-1,-5.05367549898d-1, - @ 8.21896973657d-1,-2.5222672453,6.1007027481, - @ -8.51001627836,4.6535116765/ - -c *********** - -c equivalent width of atmospheric line. - - pi = acos(-1.d0) - - if ( idummy.gt.9 ) - @ write (*,*) ' S, m, alsa, pp =', ka(kr), me, alsa(kr), pl - - y=ka(kr)*me -! x=y/(2.0*pi*(alsa(kr)*pl+alna(kr)*(pe-pl))) - x=y/(2.0d0*pi* alsa(kr)*pl) !+alna(kr)*(pe-pl))) - -! Strong limit of Lorentz profile: WL = 2 SQRT( S * m * alsa*pl ) -! Para anular esto, comentar las siguientes 5 lineas -! if ( x .gt. 1.e6 ) then -! wl = 2.0*sqrt( y * alsa(kr)*pl ) -! else -! wl=y/sqrt(1.0d0+pi*x/2.0d0) -! endif - - wl=y/sqrt(1.0d0+pi*x/2.0d0) - - if (wl .le. 0.d0) then - write(*,*)'mztfsub_overlap/496',ig,y,ka(kr),me,kr - stop'WE/Lorentz EQW zero or negative!/498'!,ig - endif - - if ( idummy.gt.9 ) - @ write (*,*) ' y, x =', y, x - - xlor = x - if ( (idummy.eq.2 .or. idummy.eq.12) .and. xlor.gt.1e5 ) then - ! en caso que estemos en el regimen - ! Strong Lorentz y la presion local - ! vaya disminuyendo, corregimos la EQW - ! con un gradiente analitico (notebook) - wsL = 2.0*sqrt( y * alsa(kr)*pl ) - wsl_grad = - 2.d0 * ka(kr)*alsa(kr) * nt_local*p_local / wsL - wlgood = w_strongLor_prev(kr) + wsl_grad * Desp - if (idummy.eq.12) - @ write (*,*) ' W(wrong), W_SL, W_SL prev, W_SL corrected=', - @ wl, wsL, w_strongLor_prev(kr), wlgood - wl = wlgood - endif - ! wsL = wl pero esto no lo hacemos todavia, porque necesitamos - ! el valor que ahora mismo tiene wsL para corregir la - ! expresion R&W below - -! write (*,*) 'WE arguments me,pe,pl =', me,pe,pl -! write (*,*) 'WE/ wl,ka(kr),alsa(kr) =', -! @ wl, ka(kr),alsa(kr) - - -!>>>>>>> - 500 format (a,i3,3(2x,1pe15.8)) - 600 format (a,2(2x,1pe16.9)) - 700 format (a,3(1x,1pe16.9)) -! if (kr.eq.8 .or. kr.eq.13) then -! write (*,500) 'WE/kr,m,pt,pl=', kr, me, pe, pl -! write (*,700) ' /aln,als,d_x=', alna(kr),alsa(kr), -! @ 2.0*pi*( alsa(kr)*pl + alna(kr)*(pe-pl) ) -! write (*,600) ' /alsa*p_CO2, alna*p_n2 :', -! @ alsa(kr)*pl, alna(kr)*(pe-pl) -! write (*,600) ' a*p, S =', -! @ alsa(kr)*pl + alna(kr)*(pe-pl) , ka(kr) -! write (*,600) ' /S*m, x =', y, x -! write (*,600) ' /aprox, WL =', -! @ 2.*sqrt( y*( alsa(kr)*pl+alna(kr)*(pe-pl) ) ), WL -! endif - ! - ! corrections to lorentz eqw due to overlaping and super-saturation - ! - - i_supersat = 0 - - if ( icls.eq.5 .and. ioverlap.gt.0 ) then - ! for the moment, only consider overlaping for mztf.f, not fot.f - - ! definition of saturation in the lisat model - ! - asat_box = 0.99d0 - f_sat_box = 2.d0 * x - xx = f_sat_box / log( 1./(1-asat_box) ) - if ( xx .lt. 1.0d0 ) then - dv_sat_box = 0.0d0 - asat_box = 1.0d0 - exp( - f_sat_box ) - else - dv_sat_box = alsa(kr) * sqrt( xx - 1.0d0 ) - ! approximation: only use of alsa in mars and venus - endif - - ! area of saturated line - ! - area_core_box = 2.d0 * dv_sat_box * asat_box - area_wing_box = 0.5d0 * ( wl - area_core_box ) - dv_corte_box = dv_sat_box + 2.d0*area_wing_box/asat_box - - ! super-saturation or simple overlaping? - ! -! i_supersat = 0 - xx = dv_sat_box - ( 0.5d0 * dist(kr) ) - if ( xx .ge. 0.0 ! definition of supersaturation - @ .and. dv_sat_box .gt. 0.0 ! definition of saturation - @ .and. (dist(kr).gt.0.0) ) ! box contains more than 1 line - @ ! and not too far apart - @ then - - i_supersat = 1 - - else - ! no super-saturation, then use "lisat + first correction", i.e., - ! correct for line products - ! - - wl = wl - - endif - - end if ! end of overlaping loop - - if (icls.eq.2) then - we = wl - return - endif - -cc doppler limit: - if ( idummy.gt.9 ) - @ write (*,*) ' S*m, alf_dop =', y, alda(kr)*sqrt(pi) - - x = y / (alda(kr)*sqrt(pi)) - if ( x.lt.1.e-10 ) then ! to avoid underflow - wd = y - else - wd=alda(kr)*sqrt(4.0*pi*x**2*(1.0+log(1.0+x))/(4.0+pi*x**2)) - endif - if ( idummy.gt.9 ) - @ write (*,*) ' wd =', wd - -cc doppler weak limit -c wd = ka(kr) * me - -cc good doppler - if(icls.eq.5) then !para mztf - !write (*,*) 'para mztf, icls=',icls - if (x.lt.5.) then - wd = 0.d0 - do i=0,7 - wd = wd + cn(i) * x**i - end do - wd = alda(kr) * x * sqrt(pi) * wd - elseif (x.gt.5.) then - wd = 0.d0 - do i=0,7 - wd = wd + dn(i) / (log(x))**i - end do - wd = alda(kr) * sqrt(log(x)) * wd - else - stop ' x should not be less than zero' - end if - end if - - - if ( i_supersat .eq. 0 ) then - - parentesis = wl**2+wd**2-(wd*wl/y)**2 - ! changed +(wd*wl/y)**2 to -...14-3-84 - - if ( parentesis .lt. 0.0 ) then - if ((idummy.eq.2 .or. idummy.eq.12) .and. xlor.gt.1e5) then - parentesis = wl**2+wd**2-(wd*wsL/y)**2 - ! este cambio puede ser necesario cuando se hace - ! correccion Strong Lor, para evitar valores - ! negativos del parentesis en sqrt( ) - else - stop ' WE/ Error en las EQW wl,wl,y ' - endif - endif - - we = sqrt( parentesis ) -! write (*,*) ' from we: xdop,alda,wd', sngl(x),alda(kr),sngl(wd) -! write (*,*) ' from we: we', we - - else - - we = wl - ! if there is supersaturation we can ignore wd completely; - ! mztf.f will compute the eqw of the whole box afterwards - - endif - - if (icls.eq.3) we = wd - - if ( idummy.gt.9 ) - @ write (*,*) ' wl,wd,w =', wl,wd,we - - wsL = wl - - return - end - - -c ********************************************************************** - real*8 function simrul(a,b,fsim,c,acc) -c adaptively integrates fsim from a to b, within the criterion acc. -c ********************************************************************** - - implicit none - - real*8 res,a,b,g0,g1,g2,g3,g4,d,a0,a1,a2,h,x,acc,c,fsim - real*8 s1(70),s2(70),s3(70) - real*8 c1, c2 - integer*4 m,n,j - - res=0. - c=0. - m=0 - n=0 - j=30 - g0=fsim(a) - g2=fsim((a+b)/2.) - g4=fsim(b) - a0=(b-a)*(g0+4.0*g2+g4)/2.0 - 1 d=2.0**n - h=(b-a)/(4.0*d) - x=a+(4.0*m+1.0)*h - g1=fsim(x) - g3=fsim(x+2.0*h) - a1=h*(g0+4.0*g1+g2) - a2=h*(g2+4.0*g3+g4) - if ( abs(a1+a2-a0).gt.(acc/d)) goto 2 - res=res+(16.0*(a1+a2)-a0)/45.0 - m=m+1 - c=a+m*(b-a)/d - 6 if (m.eq.(2*(m/2))) goto 4 - if ((m.ne.1).or.(n.ne.0)) goto 5 - 8 simrul=res - return - 2 m=2*m - n=n+1 - if (n.gt.j) goto 3 - a0=a1 - s1(n)=a2 - s2(n)=g3 - s3(n)=g4 - g4=g2 - g2=g1 - goto 1 - 3 c1=c-(b-a)/d - c2=c+(b-a)/d - write(2,7) c1,c,c2,fsim(c1),fsim(c),fsim(c2) - write(*,7) c1,c,c2,fsim(c1),fsim(c),fsim(c2) - 7 format(2x,17hsimrule fails at ,/,3e15.6,/,3e15.6) - goto 8 - 5 a0=s1(n) - g0=g4 - g2=s2(n) - g4=s3(n) - goto 1 - 4 m=m/2 - n=n-1 - goto 6 - end - -c ********************************************************************** - subroutine findw(ig,iirw,idummy,c1,p1, Desp, wsL) -c this routine sets up accuracy criteria and calls simrule between limit -c that depend on the number of atmospheric and cell paths. it gives eqw. - -c Add correction for EQW in Strong Lorentz regime and SZA>90 -c ********************************************************************** - - implicit none - include 'nltedefs.h' - include 'nlte_curtis.h' - -c arguments - integer ig ! ADDED FOR TRACEBACK - integer iirw - integer idummy ! I. indica varias opciones - real*8 c1 ! I. needed for strong limit of Lorentz profil - real*8 p1 ! I. " " " - real*8 wsL ! O. need this for strong Lorentz correction - real*8 Desp ! I. need this for strong Lorentz correction - -c local variables - real*8 ept,eps,xa - real*8 acc, c - real*8 we - real*8 f, fi, simrul - - external f,fi - -c ********** *********** ********* - - if(icls.eq.5) then !para mztf -! if(ig.eq.1682)write(*,*)'mztfsub_overlap/768',ua(kr),iirw - if (iirw.eq.2) then !iirw=icf=2 ==> we use the w&r formula - w = we(ig,ua(kr),pt,pp, idummy, c1,p1, Desp, wsL ) - return - end if - ept=we(ig,ua(kr),pt,pp, idummy,c1,p1, Desp, wsL) - else !para fot - if (iirw.eq.2) then ! icf=2 ==> we use the w&r formula - w = we(ig,sl_ua,pt,pp, idummy,c1,p1, Desp, wsL) - return - end if - ept=we(ig,sl_ua,pt,pp, idummy,c1,p1, Desp, wsL) - end if - -c the next block is a modification to avoid nul we. -c this situation appears for weak lines and low path temperature, but -c there is not any loss of accuracy. first july 1986 - if (ept.eq.0.) then ! for weak lines sometimes we=0 - ept=1.0e-18 - write (*,*) 'ept =',ept - write (*,*) 'from we: we=0.0' - return - end if - - acc = 4.d0 - acc = 10.d0**(-acc) - - eps = acc * ept !accuracy 10-4 atmospheric eqw. - xa=0.5*ept/f(0.d0) !width of doppler shifted atmospheric line. - w=2.0*(simrul(0.0d0,xa,f,c,eps)+simrul(0.1d0,1.0/xa,fi,c,eps)) -!no shift. - - return - end - - -c ********************************************************************** - double precision function fi(y) -c returns the value of f(1/y) -c ********************************************************************** - - implicit none - real*8 f, y - - fi=f(1.0/y)/y**2 - return - end - - -c ********************************************************************** - double precision function f(nu) -c calculates 1-exp(-k(nu)u) for all series paths or combinations thereof -c ********************************************************************** - - implicit none - include 'nltedefs.h' - include 'nlte_curtis.h' - - double precision tra,xa,ya,za,yy,nu - double precision voigtf - tra=1.0d0 - - yy=1.0d0/alda(kr) - xa=nu*yy - ya= ( alsa(kr)*pp + alna(kr)*(pt-pp) ) * yy - za=ka(kr)*yy - - if(icls.eq.5) then !para mztf - ! write (*,*) 'icls=',icls - tra=za*ua(kr)*voigtf(sngl(xa),sngl(ya)) - else - tra=za*sl_ua*voigtf(sngl(xa),sngl(ya)) - end if - - if (tra.gt.50.0) then - tra=1.0 !2.0e-22 overflow cut-off. - else if (tra.gt.1.0e-4) then - tra=1.0-exp(-tra) - end if - - f=tra - return - end - -c ********************************************************************** - double precision function voigtf(x1,y) -c computes voigt function for any value of x1 and any +ve value of y. -c where possible uses modified lorentz and modified doppler approximatio -c otherwise uses a rearranged rybicki routine. -c c(n) = exp(-(n/h)**2)/(pi*sqrt(pi)), with h = 2.5 . -c accurate to better than 1 in 10000. -c ********************************************************************** - - implicit none - - real x1, y - real x, xx, xxyy, xh,xhxh, yh,yhyh, f1,f2, p, q, xn,xnxn, voig - - real*8 b,g0,g1,g2,g3,g4,d1,d2,d3,d4,c - integer*4 n - - dimension c(10) - complex xp,xpp,z - - data c(1)/0.15303405/ - data c(2)/0.94694928e-1/ - data c(3)/0.42549174e-1/ - data c(4)/0.13882935e-1/ - data c(5)/0.32892528e-2/ - data c(6)/0.56589906e-3/ - data c(7)/0.70697890e-4/ - data c(8)/0.64135678e-5/ - data c(9)/0.42249221e-6/ - data c(10)/0.20209868e-7/ - - x=abs(x1) - if (x.gt.7.2) goto 1 - if ((y+x*0.3).gt.5.4) goto 1 - if (y.gt.0.01) goto 3 - if (x.lt.2.1) goto 2 - goto 3 -c here uses modified lorentz approx. - 1 xx=x*x - xxyy=xx+y*y - b=xx/xxyy - voigtf=y*(1.+(2.*b-0.5+(0.75-(9.-12.*b)*b)/xxyy)/ - * xxyy)/(xxyy*3.141592654) - return -c here uses modified doppler approx. - 2 xx=x*x - voigtf=0.56418958*exp(-xx)*(1.-y*(1.-0.5*y)*(1.1289-xx*(1.1623+ - * xx*(0.080812+xx*(0.13854-xx*(0.033605-0.0073972*xx)))))) - return -c here uses a rearranged rybicki routine. - 3 xh=2.5*x - xhxh=xh*xh - yh=2.5*y - yhyh=yh*yh - f1=xhxh+yhyh - f2=f1-0.5*yhyh - if (y.lt.0.1) goto 20 - p=-y*7.8539816 !7.8539816=2.5*pi - q=x*7.8539816 - xpp=cmplx(p,q) - z=cexp(xpp) - d1=xh*aimag(z) - d2=-d1 - d3=yh*(1.-real(z)) - d4=-d3+2.*yh - voig=0.17958712*(d1+d3)/f1 - goto 30 - 20 p=x*7.8539816 - q=y*7.8539816 - xp=cmplx(p,q) - z=ccos(xp) - d1=xh*aimag(z) - d2=-d1 - d3=yh*(1.-real(z)) - d4=-d3+2.*yh - voig=0.56418958*exp(y*y-x*x)*cos(2.*x*y)+0.17958712*(d1+d3)/f1 - 30 xn=0. - do 55 n=1,10,2 - xn=xn+1. - xnxn=xn*xn - g1=xh-xn - g2=g1*(xh+xn) - g3=0.5*g2*g2 - voig=voig+c(n)*(d2*(g2+yhyh)+d4*(f1+xnxn))/(g3+yhyh*(f2+xnxn)) - xn=xn+1. - xnxn=xn*xn - g1=xh-xn - g2=g1*(xh+xn) - g3=0.5*g2*g2 - voig=voig+c(n+1)*(d1*(g2+yhyh)+d3*(f1+xnxn))/ - @ (g3+yhyh*(f2+xnxn)) - 55 continue - voigtf=voig - return - end Index: trunk/LMDZ.MARS/libf/phymars/mztud.F =================================================================== --- trunk/LMDZ.MARS/libf/phymars/mztud.F (revision 496) +++ (revision ) @@ -1,789 +1,0 @@ -c*********************************************************************** -c mztf.f -c*********************************************************************** - - subroutine mztud ( ig,cf,cfup,cfdw,vc,taugr, ib,isot, - @ iirw,iimu,itauout,icfout,itableout ) - -c program for calculating atmospheric transmittances -c to be used in the calculation of curtis matrix coefficients -c i*out = 1 output of data -c i*out = 0 no output -c itableout = 30 output de toda la C.M. y el VC y las poblaciones de los -c estados 626(020), esta opcion nueva se añade porque -c itableout=1 saca o bien solamente de 5 en 5 capas -c o bien los elementos de C.M. desde una cierta capa -c (consultese elimin_mz1d.f que es quien lo hace); lo -c de las poblaciones (020) lo hace mztf_correcion.f - -c jul 2011 malv+fgg Adapted to LMD-MGCM -c jan 07 malv Add new vertical fine grid zy, similar to zx -c sep-oct 01 malv update for fluxes for hb and fb, adapt to Linux -c nov 98 mavl allow for overlaping in the lorentz line -c jan 98 malv version for mz1d. based on curtis/mztf.for -c 17-jul-96 mlp&crs change the calculation of mr. -c evitar: divide por cero. anhadiendo: ff -c oct-92 malv correct s(t) dependence for all histogr bands -c june-92 malv proper lower levels for laser bands -c may-92 malv new temperature dependence for laser bands -c @ 991 malv boxing for the averaged absorber amount and t -c ? malv extension up to 200 km altitude in mars -c 13-nov-86 mlp include the temperature weighted to match -c the eqw in the strong doppler limit. -c*********************************************************************** - - implicit none - - include 'nltedefs.h' - include 'nlte_atm.h' - include 'nlte_data.h' - include 'nlte_curtis.h' - include 'tcr_15um.h' - include 'nlte_results.h' - -c arguments - integer ig !ADDED FOR TRACEBACK - real*8 cf(nl,nl), cfup(nl,nl), cfdw(nl,nl) ! o - real*8 vc(nl), taugr(nl) ! o - integer ib ! i - integer isot ! i - integer iirw ! i - integer iimu ! i - integer itauout ! i - integer icfout ! i - integer itableout ! i - -c local variables and constants - integer i, in, ir, im, k,j - integer nmu - parameter (nmu = 8) - real*8 tau(nl,nl) - real*8 tauinf(nl) - real*8 con(nzy), coninf - real*8 c1, c2 - real*8 t1, t2 - real*8 p1, p2 - real*8 mr1, mr2 - real*8 st1, st2 - real*8 c1box(70), c2box(70) - real*8 ff ! to avoid too small numbers - real*8 tvtbs(nzy) - real*8 st, beta, ts, eqwmu - real*8 mu(nmu), amu(nmu) - real*8 zld(nl), zyd(nzy) - real*8 correc - real deltanux ! width of vib-rot band (cm-1) - character isotcode*2 - integer idummy - real*8 Desp,wsL - -c formats - 111 format(a1) - 112 format(a2) - 101 format(i1) - 202 format(i2) - 180 format(a80) - 181 format(a80) -c*********************************************************************** - -c some needed values -! rl=sqrt(log(2.d0)) -! pi2 = 3.14159265358989d0 - beta = 1.8d0 -! beta = 1.0d0 - idummy = 0 - Desp = 0.0d0 - wsL = 0.0d0 - - !write (*,*) ' MZTUD/ iirw = ', iirw - - -c esto es para que las subroutines de mztfsub calculen we -c de la forma apropiada para mztf, no para fot - icls=icls_mztf - -c codigos para filenames -! if (isot .eq. 1) isotcode = '26' -! if (isot .eq. 2) isotcode = '28' -! if (isot .eq. 3) isotcode = '36' -! if (isot .eq. 4) isotcode = '27' -! if (isot .eq. 5) isotcode = '62' -! if(ib.eq.1.or.ib.eq.2.or.ib.eq.3.or.ib.eq.4.or.ib.eq.5 -! @ .or.ib.eq.6.or.ib.eq.7.or.ib.eq.8.or.ib.eq.9) then -! write (ibcode1,101) ib -! else -! write (ibcode2,202) ib -! endif -! write (*,'( 30h calculating curtis matrix : ,2x, -! @ 8h band = ,i2,2x, 11h isotope = ,i2)') ib, isot - -c integration in angle !!!!!!!!!!!!!!!!!!!! -c------- diffusivity approx. - if (iimu.eq.1) then -! write (*,*) ' diffusivity approx. beta = ',beta - mu(1) = 1.0d0 - amu(1)= 1.0d0 -c-------data for 8 points integration - elseif (iimu.eq.4) then - write (*,*)' 4 points for the gauss-legendre angle quadrature.' - mu(1)=(1.0d0+0.339981043584856)/2.0d0 - mu(2)=(1.0d0-0.339981043584856)/2.0d0 - mu(3)=(1.0d0+0.861136311594053)/2.0d0 - mu(4)=(1.0d0-0.861136311594053)/2.0d0 - amu(1)=0.652145154862546 - amu(2)=amu(1) - amu(3)=0.347854845137454 - amu(4)=amu(3) - beta=1.0d0 -c-------data for 8 points integration - elseif(iimu.eq.8) then - write (*,*)' 8 points for the gauss-legendre angle quadrature.' - mu(1)=(1.0d0+0.183434642495650)/2.0d0 - mu(2)=(1.0d0-0.183434642495650)/2.0d0 - mu(3)=(1.0d0+0.525532409916329)/2.0d0 - mu(4)=(1.0d0-0.525532409916329)/2.0d0 - mu(5)=(1.0d0+0.796666477413627)/2.0d0 - mu(6)=(1.0d0-0.796666477413627)/2.0d0 - mu(7)=(1.0d0+0.960289856497536)/2.0d0 - mu(8)=(1.0d0-0.960289856497536)/2.0d0 - amu(1)=0.362683783378362 - amu(2)=amu(1) - amu(3)=0.313706645877887 - amu(4)=amu(3) - amu(5)=0.222381034453374 - amu(6)=amu(5) - amu(7)=0.101228536290376 - amu(8)=amu(7) - beta=1.0d0 - end if -c!!!!!!!!!!!!!!!!!!!!!!! - -ccc -ccc determine abundances included in the absorber amount -ccc - -c first, set up the grid ready for interpolation. - do i=1,nzy - zyd(i) = dble(zy(i)) - enddo - do i=1,nl - zld(i) = dble(zl(i)) - enddo -c vibr. temp of the bending mode : - if (isot.eq.1) call interdp ( tvtbs,zyd,nzy, v626t1,zld,nl, 1 ) - if (isot.eq.2) call interdp ( tvtbs,zyd,nzy, v628t1,zld,nl, 1 ) - if (isot.eq.3) call interdp ( tvtbs,zyd,nzy, v636t1,zld,nl, 1 ) - if (isot.eq.4) call interdp ( tvtbs,zyd,nzy, v627t1,zld,nl, 1 ) - !if (isot.eq.5) call interdp ( tvtbs,zxd,nz, vcot1,zld,nl, 1 ) - -c 2nd: correccion a la n10(i) (cantidad de absorbente en el lower state) -c por similitud a la que se hace en cza.for ; esto solo se hace para CO2 - !write (*,*) 'imr(isot) = ', isot, imr(isot) - do i=1,nzy - if (isot.eq.5) then - con(i) = dble( coy(i) * imrco ) - else - con(i) = dble( co2y(i) * imr(isot) ) - correc = 2.d0 * dexp( dble(-ee*elow(isot,2))/tvtbs(i) ) - con(i) = con(i) * ( 1.d0 - correc ) -! write (*,*) ' iz, correc, co2y(i), con(i) =', -! @ i,correc,co2y(i),con(i) - endif - - !----------------------------------------------------------------- - ! mlp & cristina. 17 july 1996 change the calculation of mr. - ! it is used for calculating partial press - ! alpha = alpha(self,co2)*pp +alpha(n2)*(pt-pp) - ! for an isotope, if mr is obtained by - ! co2*imr(iso)/nt - ! we are considerin collisions with other co2 isotopes - ! (including the major one, 626) as if they were with n2. - ! assuming mr as co2/nt, we consider collisions - ! of type 628-626 as of 626-626 instead of as 626-n2. - ! mrx(i)=con(i)/ntx(i) ! old malv - ! mrx(i)= dble(co2x(i)/ntx(i)) ! mlp & crs - - ! jan 98: - ! esta modif de mlp implica anular el correc (deberia revisar esto) - - mr(i) = dble(co2y(i)/nty(i)) ! malv, jan 98 - - !----------------------------------------------------------------- - - end do -! como beta y 1.d5 son comunes a todas las weighted absorber amounts, -! los simplificamos: -! coninf = beta * 1.d5 * dble( con(n) / log( con(n-1) / con(n) ) ) - !write (*,*) ' con(nz), con(nz-1) =', con(nz), con(nz-1) - coninf = dble( con(nzy) / log( con(nzy-1) / con(nzy) ) ) -! if(ig.eq.1682)write(*,*)'mztud/218',coninf,con(nzy), -! 1 con(nzy-1),log(con(nzy-1)/con(nzy)),co2y(nzy),co2y(nzy-1) - !write (*,*) ' coninf =', coninf - -ccc -ccc temp dependence of the band strength and -ccc nlte correction factor for the absorber amount -ccc - call mztf_correccion ( coninf, con, ib, isot, itableout ) -! if(ig.eq.1682)write(*,*)'mztud/227',coninf -ccc -ccc reads histogrammed spectral data (strength for lte and vmr=1) -ccc - !hfile1 = dirspec//'hi'//dn !Ya no hacemos distincion d/n en esto -! hfile1 = dirspec//'hid' !(see why in his.for) -! hfile1='hid' -!! if (ib.eq.13 .or. ib.eq.14 ) hfile1 = dirspec//'his' -! if (ib.eq.13 .or. ib.eq.14 ) hfile1 = 'his' - -! if(ib.eq.1.or.ib.eq.2.or.ib.eq.3.or.ib.eq.4.or.ib.eq.5 -! @ .or.ib.eq.6.or.ib.eq.7.or.ib.eq.8.or.ib.eq.9) then -! if (isot.eq.1) hisfile = hfile1//'26-'//ibcode1//'.dat' -! if (isot.eq.2) hisfile = hfile1//'28-'//ibcode1//'.dat' -! if (isot.eq.3) hisfile = hfile1//'36-'//ibcode1//'.dat' -! if (isot.eq.4) hisfile = hfile1//'27-'//ibcode1//'.dat' -! if (isot.eq.5) hisfile = hfile1//'62-'//ibcode1//'.dat' -! else -! if (isot.eq.1) hisfile = hfile1//'26-'//ibcode2//'.dat' -! if (isot.eq.2) hisfile = hfile1//'28-'//ibcode2//'.dat' -! if (isot.eq.3) hisfile = hfile1//'36-'//ibcode2//'.dat' -! if (isot.eq.4) hisfile = hfile1//'27-'//ibcode2//'.dat' -! if (isot.eq.5) hisfile = hfile1//'62-'//ibcode2//'.dat' -! endif - if(ib.eq.1) then - if(isot.eq.1) then !Case 1 - mm=mm_c1 - nbox=nbox_c1 - tmin=tmin_c1 - tmax=tmax_c1 - do i=1,nbox_max - no(i)=no_c1(i) - dist(i)=dist_c1(i) - do j=1,nhist - sk1(j,i)=sk1_c1(j,i) - xls1(j,i)=xls1_c1(j,i) - xln1(j,i)=xln1_c1(j,i) - xld1(j,i)=xld1_c1(j,i) - enddo - enddo - do j=1,nhist - thist(j)=thist_c1(j) - enddo - else if(isot.eq.2) then !Case 2 - mm=mm_c2 - nbox=nbox_c2 - tmin=tmin_c2 - tmax=tmax_c2 - do i=1,nbox_max - no(i)=no_c2(i) - dist(i)=dist_c2(i) - do j=1,nhist - sk1(j,i)=sk1_c2(j,i) - xls1(j,i)=xls1_c2(j,i) - xln1(j,i)=xln1_c2(j,i) - xld1(j,i)=xld1_c2(j,i) - enddo - enddo - do j=1,nhist - thist(j)=thist_c2(j) - enddo - else if(isot.eq.3) then !Case 3 - mm=mm_c3 - nbox=nbox_c3 - tmin=tmin_c3 - tmax=tmax_c3 - do i=1,nbox_max - no(i)=no_c3(i) - dist(i)=dist_c3(i) - do j=1,nhist - sk1(j,i)=sk1_c3(j,i) - xls1(j,i)=xls1_c3(j,i) - xln1(j,i)=xln1_c3(j,i) - xld1(j,i)=xld1_c3(j,i) - enddo - enddo - do j=1,nhist - thist(j)=thist_c3(j) - enddo - else if(isot.eq.4) then !Case 4 - mm=mm_c4 - nbox=nbox_c4 - tmin=tmin_c4 - tmax=tmax_c4 - do i=1,nbox_max - no(i)=no_c4(i) - dist(i)=dist_c4(i) - do j=1,nhist - sk1(j,i)=sk1_c4(j,i) - xls1(j,i)=xls1_c4(j,i) - xln1(j,i)=xln1_c4(j,i) - xld1(j,i)=xld1_c4(j,i) - enddo - enddo - do j=1,nhist - thist(j)=thist_c4(j) - enddo - else - write(*,*)'isot must be 2,3 or 4 for ib=1!!' - write(*,*)'stop at mztud/324' - stop - endif - else if (ib.eq.2) then - if(isot.eq.1) then !Case 5 - mm=mm_c5 - nbox=nbox_c5 - tmin=tmin_c5 - tmax=tmax_c5 - do i=1,nbox_max - no(i)=no_c5(i) - dist(i)=dist_c5(i) - do j=1,nhist - sk1(j,i)=sk1_c5(j,i) - xls1(j,i)=xls1_c5(j,i) - xln1(j,i)=xln1_c5(j,i) - xld1(j,i)=xld1_c5(j,i) - enddo - enddo - do j=1,nhist - thist(j)=thist_c5(j) - enddo - else - write(*,*)'isot must be 1 for ib=2!!' - write(*,*)'stop at mztud/348' - stop - endif - else if (ib.eq.3) then - if(isot.eq.1) then !Case 6 - mm=mm_c6 - nbox=nbox_c6 - tmin=tmin_c6 - tmax=tmax_c6 - do i=1,nbox_max - no(i)=no_c6(i) - dist(i)=dist_c6(i) - do j=1,nhist - sk1(j,i)=sk1_c6(j,i) - xls1(j,i)=xls1_c6(j,i) - xln1(j,i)=xln1_c6(j,i) - xld1(j,i)=xld1_c6(j,i) - enddo - enddo - do j=1,nhist - thist(j)=thist_c6(j) - enddo - else - write(*,*)'isot must be 1 for ib=3!!' - write(*,*)'stop at mztud/372' - stop - endif - else if (ib.eq.4) then - if(isot.eq.1) then !Case 7 - mm=mm_c7 - nbox=nbox_c7 - tmin=tmin_c7 - tmax=tmax_c7 - do i=1,nbox_max - no(i)=no_c7(i) - dist(i)=dist_c7(i) - do j=1,nhist - sk1(j,i)=sk1_c7(j,i) - xls1(j,i)=xls1_c7(j,i) - xln1(j,i)=xln1_c7(j,i) - xld1(j,i)=xld1_c7(j,i) - enddo - enddo - do j=1,nhist - thist(j)=thist_c7(j) - enddo - else - write(*,*)'isot must be 1 for ib=4!!' - write(*,*)'stop at mztud/396' - stop - endif - else - write(*,*)'ib must be 1,2,3 or 4!!' - write(*,*)'stop at mztud/401' - endif - - - - -! write (*,*) 'hisfile: ', hisfile -! the argument to rhist is to make this compatible with mztf_comp.f, -! which is a useful modification of mztf.f (to change strengths of bands -! call rhist (1.0) - if (isot.ne.5) deltanux = deltanu(isot,ib) - if (isot.eq.5) deltanux = deltanuco - -c****** -c****** calculation of tauinf(nl) -c****** - call initial - ff=1.0e10 - - do i=nl,1,-1 - - if(i.eq.nl)then - - call intz (zl(i),c2,p2,mr2,t2, con) - do kr=1,nbox - ta(kr)=t2 - end do -! write (*,*) ' i, t2 =', i, t2 - call interstrength (st2,t2,ka,ta) - aa = p2 * coninf * mr2 * (st2 * ff) - bb = p2 * coninf * st2 - cc = coninf * st2 - dd = t2 * coninf * st2 - do kr=1,nbox - ccbox(kr) = coninf * ka(kr) -! if(i.eq.nl.and.ig.eq.1682)write(*,*)'mztud/435', -! 1 ccbox(kr),coninf,ka(kr),kr - ddbox(kr) = t2 * ccbox(kr) -! c2box(kr) = c2 * ka(kr) * beta * dble(deltaz) * 1.d5 - c2box(kr) = c2 * ka(kr) * dble(deltaz) - end do -! c2 = c2 * st2 * beta * dble(deltaz) * 1.d5 - c2 = c2 * st2 * dble(deltaz) - - else - call intz (zl(i),c1,p1,mr1,t1, con) - do kr=1,nbox - ta(kr)=t1 - end do -! write (*,*) ' i, t1 =', i, t1 - call interstrength (st1,t1,ka,ta) - do kr=1,nbox -! c1box(kr) = c1 * ka(kr) * beta * dble(deltaz) * 1.d5 - c1box(kr) = c1 * ka(kr) * dble(deltaz) - end do -! c1 = c1 * st1 * beta * dble(deltaz) * 1.d5 - c1 = c1 * st1 * dble(deltaz) - aa = aa + ( p1*mr1*(c1*ff) + p2*mr2*(c2*ff)) / 2.d0 - bb = bb + ( p1*c1 + p2*c2 ) / 2.d0 - cc = cc + ( c1 + c2 ) / 2.d0 - dd = dd + ( t1*c1 + t2*c2 ) / 2.d0 - do kr=1,nbox - ccbox(kr) = ccbox(kr) + - @ ( c1box(kr) + c2box(kr) )/2.d0 -! if(i.eq.nl.and.ig.eq.1682)write(*,*)'mztud/464', -! 1 ccbox(kr),c1box(kr),c2box(kr),kr - ddbox(kr) = ddbox(kr) + - @ ( t1*c1box(kr)+t2*c2box(kr) )/2.d0 - end do - - mr2 = mr1 - c2=c1 - do kr=1,nbox - c2box(kr) = c1box(kr) - end do - t2=t1 - p2=p1 - end if - - pt = bb / cc - pp = aa / (cc*ff) - -! ta=dd/cc -! tdop = ta - ts = dd/cc - do kr=1,nbox - ta(kr) = ddbox(kr) / ccbox(kr) - end do -! write (*,*) ' i, ts =', i, ts - call interstrength(st,ts,ka,ta) -! call intershape(alsa,alna,alda,tdop) - call intershape(alsa,alna,alda,ta) -* ua = cc/st - -c next loop calculates the eqw for an especified path uapp,pt,ta - - eqwmu = 0.0d0 - do im = 1,iimu - eqw=0.0d0 - do kr=1,nbox - ua(kr) = ccbox(kr) / ka(kr) * beta * 1.0d5 / mu(im) - if(ua(kr).lt.0.)write(*,*)'mztud/504',ua(kr),ccbox(kr), - $ ka(kr),beta,mu(im),kr,im,i,nl - call findw(ig,iirw, idummy,c1,p1,Desp,wsL) - if ( i_supersat .eq. 0 ) then - eqw=eqw+no(kr)*w - else - eqw = w + (no(kr)-1) * ( asat_box*dist(kr) ) - endif - end do - eqwmu = eqwmu + eqw * mu(im)*amu(im) - end do - - tauinf(i) = exp( - eqwmu / dble(deltanux) ) - - end do ! i continue -! if ( isot.eq.1 .and. ib.eq.2 ) then -! write (*,*) ' tauinf(nl) = ', tauinf(nl) -! write (*,*) ' tauinf(1) = ', tauinf(1) -! endif - -c****** -c****** calculation of tau(in,ir) for n<=r -c****** - - do 1 in=1,nl-1 - call initial - call intz (zl(in), c1,p1,mr1,t1, con) - do kr=1,nbox - ta(kr) = t1 - end do - call interstrength (st1,t1,ka,ta) - do kr=1,nbox -! c1box(kr) = c1 * ka(kr) * beta * dble(deltaz) * 1.d5 - c1box(kr) = c1 * ka(kr) * dble(deltaz) - end do -! c1 = c1 * st1 * beta * dble(deltaz) * 1.d5 - c1 = c1 * st1 * dble(deltaz) - - do 2 ir=in,nl-1 - - if (ir.eq.in) then - tau(in,ir) = 1.d0 - goto 2 - end if - - call intz (zl(ir), c2,p2,mr2,t2, con) - do kr=1,nbox - ta(kr) = t2 - end do - call interstrength (st2,t2,ka,ta) - do kr=1,nbox -! c2box(kr) = c2 * ka(kr) * beta * dble(deltaz) * 1.d5 - c2box(kr) = c2 * ka(kr) * dble(deltaz) - end do -! c2 = c2 * st2 * beta * dble(deltaz) * 1.e5 - c2 = c2 * st2 * dble(deltaz) - -c aa = aa + ( p1*mr1*c1 + p2*mr2*c2 ) / 2.d0 - aa = aa + ( p1*mr1*(c1*ff) + p2*mr2*(c2*ff)) / 2.d0 - bb = bb + ( p1*c1 + p2*c2 ) / 2.d0 - cc = cc + ( c1 + c2 ) / 2.d0 - dd = dd + ( t1*c1 + t2*c2 ) / 2.d0 - do kr=1,nbox - ccbox(kr) = ccbox(kr) + ( c1box(kr) + c2box(kr) ) /2.d0 - ddbox(kr) = ddbox(kr) + ( t1*c1box(kr) + t2*c2box(kr) ) /2.d0 - end do - - mr1=mr2 - t1=t2 - c1=c2 - p1=p2 - do kr=1,nbox - c1box(kr) = c2box(kr) - end do - - pt = bb / cc - pp = aa / (cc * ff) - -* ta=dd/cc -* tdop = ta - ts = dd/cc - do kr=1,nbox - ta(kr) = ddbox(kr) / ccbox(kr) - end do - call interstrength(st,ts,ka,ta) - call intershape(alsa,alna,alda,ta) -* ua = cc/st - -c next loop calculates the eqw for an especified path ua,pp,pt,ta - - eqwmu = 0.0d0 - do im = 1,iimu - eqw=0.0d0 - do kr=1,nbox - ua(kr) = ccbox(kr) / ka(kr) * beta * 1.0d5 / mu(im) - if(ua(kr).lt.0.)write(*,*)'mztud/599',ua(kr),ccbox(kr), - $ ka(kr),beta,mu(im),kr,im,i,nl - - call findw(ig,iirw, idummy,c1,p1,Desp,wsL) - if ( i_supersat .eq. 0 ) then - eqw=eqw+no(kr)*w - else - eqw = w + (no(kr)-1) * ( asat_box*dist(kr) ) - endif - end do - eqwmu = eqwmu + eqw * mu(im)*amu(im) - end do - - tau(in,ir) = exp( - eqwmu / dble(deltanux) ) - - 2 continue - - 1 continue -! if ( isot.eq.1 .and. ib.eq.2 ) then -! write (*,*) ' tau(1,*) , *=1,20 ' -! write (*,*) ( sngl(tau(1,k)), k=1,20 ) -! endif - - -c********** -c********** calculation of tau(in,ir) for n>r -c********** - - in=nl - - call initial - call intz (zl(in), c1,p1,mr1,t1, con) - do kr=1,nbox - ta(kr) = t1 - end do - call interstrength (st1,t1,ka,ta) - do kr=1,nbox -! c1box(kr) = c1 * ka(kr) * beta * dble(deltaz) * 1.d5 - c1box(kr) = c1 * ka(kr) * dble(deltaz) - end do -! c1 = c1 * st1 * beta * dble(deltaz) * 1.d5 - c1 = c1 * st1 * dble(deltaz) - - do 4 ir=in-1,1,-1 - - call intz (zl(ir), c2,p2,mr2,t2, con) - do kr=1,nbox - ta(kr) = t2 - end do - call interstrength (st2,t2,ka,ta) - do kr=1,nbox -! c2box(kr) = c2 * ka(kr) * beta * dble(deltaz) * 1.d5 - c2box(kr) = c2 * ka(kr) * dble(deltaz) - end do -! c2 = c2 * st2 * beta * dble(deltaz) * 1.d5 - c2 = c2 * st2 * dble(deltaz) - - aa = aa + ( p1*mr1*(c1*ff) + p2*mr2*(c2*ff)) / 2.d0 - bb = bb + ( p1*c1 + p2*c2 ) / 2.d0 - cc = cc + ( c1 + c2 ) / 2.d0 - dd = dd + ( t1*c1 + t2*c2 ) / 2.d0 - do kr=1,nbox - ccbox(kr) = ccbox(kr) + ( c1box(kr) + c2box(kr) ) /2.d0 - ddbox(kr) = ddbox(kr) + ( t1*c1box(kr) + t2*c2box(kr) ) /2.d0 - end do - - mr1=mr2 - c1=c2 - t1=t2 - p1=p2 - do kr=1,nbox - c1box(kr) = c2box(kr) - end do - - pt = bb / cc - pp = aa / (cc * ff) - ts = dd / cc - do kr=1,nbox - ta(kr) = ddbox(kr) / ccbox(kr) - end do - call interstrength (st,ts,ka,ta) - call intershape (alsa,alna,alda,ta) - -* ua = cc/st - -c next loop calculates the eqw for an especified path ua,pp,pt,ta - - eqwmu = 0.0d0 - do im = 1,iimu - eqw=0.0d0 - do kr=1,nbox - ua(kr) = ccbox(kr) / ka(kr) * beta * 1.0d5 / mu(im) - if(ua(kr).lt.0.)write(*,*)'mztud/691',ua(kr),ccbox(kr), - $ ka(kr),beta,mu(im),kr,im,i,nl - - call findw(ig,iirw, idummy,c1,p1,Desp,wsL) - if ( i_supersat .eq. 0 ) then - eqw=eqw+no(kr)*w - else - eqw = w + (no(kr)-1) * ( asat_box*dist(kr) ) - endif - end do - eqwmu = eqwmu + eqw * mu(im)*amu(im) - end do - - tau(in,ir) = exp( - eqwmu / dble(deltanux) ) - - 4 continue - -c -c due to the simmetry of the transmittances -c - do in=nl-1,2,-1 - do ir=in-1,1,-1 - tau(in,ir) = tau(ir,in) - end do - end do - - -ccc -ccc writing out transmittances -ccc - if (itauout.eq.1) then - -! if(ib.eq.1.or.ib.eq.2.or.ib.eq.3.or.ib.eq.4.or.ib.eq.5 -! @ .or.ib.eq.6.or.ib.eq.7.or.ib.eq.8.or.ib.eq.9) then -! open( 1, file= -! @ dircurtis//'taul'//isotcode//dn//ibcode1//'.dat', -! @ access='sequential', form='unformatted' ) -! else -! open( 1, file= -! @ dircurtis//'taul'//isotcode//dn//ibcode2//'.dat', -! @ access='sequential', form='unformatted' ) -! endif - -! write(1) dummy -! write(1)' format: (tauinf(n),(tau(n,r),r=1,nl),n=1,nl)' -! do in=1,nl -! write (1) tauinf(in), ( tau(in,ir), ir=1,nl ) -! end do -! close(unit=1) - - elseif (itauout.eq.2) then - -! if(ib.eq.1.or.ib.eq.2.or.ib.eq.3.or.ib.eq.4.or.ib.eq.5 -! @ .or.ib.eq.6.or.ib.eq.7.or.ib.eq.8.or.ib.eq.9) then -! open( 1, file= -! @ dircurtis//'taul'//isotcode//dn//ibcode1//'.dat') -! else -! open( 1, file= -! @ dircurtis//'taul'//isotcode//dn//ibcode2//'.dat') -! endif - -! !write(1,*) dummy -! !write(1,*) 'tij for curtis matrix calculations ' -! !write(1,*)' cira mars model atmosphere ' -! !write(1,*)' beta= ',beta,'deltanu= ',deltanux -! write(1,*) nl -! write(1,*) -! @ ' format: (tauinf(in),(tau(in,ir),ir=1,nl),in=1,nl)' - -! do in=1,nl -! write (1,*) tauinf(in) -! write (1,*) (tau(in,ir), ir=1,nl) -! end do -! close(unit=1) - -! if(ib.eq.1.or.ib.eq.2.or.ib.eq.3.or.ib.eq.4.or.ib.eq.5 -! @ .or.ib.eq.6.or.ib.eq.7.or.ib.eq.8.or.ib.eq.9) then -! write (*,'(1x, 31htransmitances written out in: ,a22)') -! @ 'taul'//isotcode//dn//ibcode1 -! else -! write (*,'(1x, 31htransmitances written out in: ,a22)') -! @ 'taul'//isotcode//dn//ibcode2 -! endif - - end if - -c cleaning of transmittances -! call elimin_tau(tau,tauinf,nl,nan,itableout,nw,dummy, -! @ isotcode,dn,ibcode2) - -c construction of the curtis matrix - - call mzcud ( tauinf,tau, cf,cfup,cfdw, vc,taugr, - @ ib,isot,icfout,itableout ) - -c end - return - end Index: trunk/LMDZ.MARS/libf/phymars/mztvc.F =================================================================== --- trunk/LMDZ.MARS/libf/phymars/mztvc.F (revision 496) +++ (revision ) @@ -1,490 +1,0 @@ -c*********************************************************************** - - subroutine mztvc ( ig,vc, ib,isot, - @ iirw,iimu,itauout,icfout,itableout ) - -c jul 2011 malv+fgg -c*********************************************************************** - - implicit none - - include 'comcstfi.h' - include 'nltedefs.h' - include 'nlte_atm.h' - include 'nlte_data.h' - include 'nlte_curtis.h' - include 'tcr_15um.h' - include 'nlte_results.h' - -c arguments - integer ig ! ADDED FOR TRACEBACK - real*8 cf(nl,nl), cfup(nl,nl), cfdw(nl,nl) ! o - real*8 vc(nl), taugr(nl) ! o - integer ib ! i - integer isot ! i - integer iirw ! i - integer iimu ! i - integer itauout ! i - integer icfout ! i - integer itableout ! i - -c local variables and constants - integer i, in, ir, im, k ,j - integer nmu - parameter (nmu = 8) - real*8 tau(nl,nl) - real*8 tauinf(nl) - real*8 con(nzy), coninf - real*8 c1, c2 - real*8 t1, t2 - real*8 p1, p2 - real*8 mr1, mr2 - real*8 st1, st2 - real*8 c1box(70), c2box(70) - real*8 ff ! to avoid too small numbers - real*8 tvtbs(nzy) - real*8 st, beta, ts, eqwmu - real*8 mu(nmu), amu(nmu) - real*8 zld(nl), zyd(nzy) - real*8 correc - real deltanux ! width of vib-rot band (cm-1) - character isotcode*2 - integer idummy - real*8 Desp,wsL - -c formats - 111 format(a1) - 112 format(a2) - 101 format(i1) - 202 format(i2) - 180 format(a80) - 181 format(a80) -c*********************************************************************** - -c some needed values -! rl=sqrt(log(2.d0)) -! pi2 = 3.14159265358989d0 - beta = 1.8d0 -! beta = 1.0d0 - idummy = 0 - Desp = 0.0d0 - wsL = 0.0d0 - - !write (*,*) ' MZTUD/ iirw = ', iirw - - -c esto es para que las subroutines de mztfsub calculen we -c de la forma apropiada para mztf, no para fot - icls=icls_mztf - -c codigos para filenames -! if (isot .eq. 1) isotcode = '26' -! if (isot .eq. 2) isotcode = '28' -! if (isot .eq. 3) isotcode = '36' -! if (isot .eq. 4) isotcode = '27' -! if (isot .eq. 5) isotcode = '62' -! if(ib.eq.1.or.ib.eq.2.or.ib.eq.3.or.ib.eq.4.or.ib.eq.5 -! @ .or.ib.eq.6.or.ib.eq.7.or.ib.eq.8.or.ib.eq.9) then -! write (ibcode1,101) ib -! else -! write (ibcode2,202) ib -! endif -! write (*,'( 30h calculating curtis matrix : ,2x, -! @ 8h band = ,i2,2x, 11h isotope = ,i2)') ib, isot - -c integration in angle !!!!!!!!!!!!!!!!!!!! - -c------- diffusivity approx. - if (iimu.eq.1) then -! write (*,*) ' diffusivity approx. beta = ',beta - mu(1) = 1.0d0 - amu(1)= 1.0d0 -c-------data for 8 points integration - elseif (iimu.eq.4) then - write (*,*)' 4 points for the gauss-legendre angle quadrature.' - mu(1)=(1.0d0+0.339981043584856)/2.0d0 - mu(2)=(1.0d0-0.339981043584856)/2.0d0 - mu(3)=(1.0d0+0.861136311594053)/2.0d0 - mu(4)=(1.0d0-0.861136311594053)/2.0d0 - amu(1)=0.652145154862546 - amu(2)=amu(1) - amu(3)=0.347854845137454 - amu(4)=amu(3) - beta=1.0d0 -c-------data for 8 points integration - elseif(iimu.eq.8) then - write (*,*)' 8 points for the gauss-legendre angle quadrature.' - mu(1)=(1.0d0+0.183434642495650)/2.0d0 - mu(2)=(1.0d0-0.183434642495650)/2.0d0 - mu(3)=(1.0d0+0.525532409916329)/2.0d0 - mu(4)=(1.0d0-0.525532409916329)/2.0d0 - mu(5)=(1.0d0+0.796666477413627)/2.0d0 - mu(6)=(1.0d0-0.796666477413627)/2.0d0 - mu(7)=(1.0d0+0.960289856497536)/2.0d0 - mu(8)=(1.0d0-0.960289856497536)/2.0d0 - amu(1)=0.362683783378362 - amu(2)=amu(1) - amu(3)=0.313706645877887 - amu(4)=amu(3) - amu(5)=0.222381034453374 - amu(6)=amu(5) - amu(7)=0.101228536290376 - amu(8)=amu(7) - beta=1.0d0 - end if -c!!!!!!!!!!!!!!!!!!!!!!! - -ccc -ccc determine abundances included in the absorber amount -ccc - -c first, set up the grid ready for interpolation. - do i=1,nzy - zyd(i) = dble(zy(i)) - enddo - do i=1,nl - zld(i) = dble(zl(i)) - enddo - -c vibr. temp of the bending mode : - if (isot.eq.1) call interdp ( tvtbs,zyd,nzy, v626t1,zld,nl, 1 ) - if (isot.eq.2) call interdp ( tvtbs,zyd,nzy, v628t1,zld,nl, 1 ) - if (isot.eq.3) call interdp ( tvtbs,zyd,nzy, v636t1,zld,nl, 1 ) - if (isot.eq.4) call interdp ( tvtbs,zyd,nzy, v627t1,zld,nl, 1 ) - !if (isot.eq.5) call interdp ( tvtbs,zxd,nz, vcot1,zld,nl, 1 ) - -c 2nd: correccion a la n10(i) (cantidad de absorbente en el lower state) -c por similitud a la que se hace en cza.for ; esto solo se hace para CO2 - - !write (*,*) 'imr(isot) = ', isot, imr(isot) - do i=1,nzy - if (isot.eq.5) then - con(i) = dble( coy(i) * imrco ) - else - con(i) = dble( co2y(i) * imr(isot) ) - correc = 2.d0 * dexp( dble(-ee*elow(isot,2))/tvtbs(i) ) - con(i) = con(i) * ( 1.d0 - correc ) -! write (*,*) ' iz, correc, co2y(i), con(i) =', -! @ i,correc,co2y(i),con(i) - endif - - !----------------------------------------------------------------- - ! mlp & cristina. 17 july 1996 change the calculation of mr. - ! it is used for calculating partial press - ! alpha = alpha(self,co2)*pp +alpha(n2)*(pt-pp) - ! for an isotope, if mr is obtained by - ! co2*imr(iso)/nt - ! we are considerin collisions with other co2 isotopes - ! (including the major one, 626) as if they were with n2. - ! assuming mr as co2/nt, we consider collisions - ! of type 628-626 as of 626-626 instead of as 626-n2. - ! mrx(i)=con(i)/ntx(i) ! old malv - ! mrx(i)= dble(co2x(i)/ntx(i)) ! mlp & crs - - ! jan 98: - ! esta modif de mlp implica anular el correc (deberia revisar esto) - - mr(i) = dble(co2y(i)/nty(i)) ! malv, jan 98 - - !----------------------------------------------------------------- - - end do - -! como beta y 1.d5 son comunes a todas las weighted absorber amounts, -! los simplificamos: -! coninf = beta * 1.d5 * dble( con(n) / log( con(n-1) / con(n) ) ) - !write (*,*) ' con(nz), con(nz-1) =', con(nz), con(nz-1) - coninf = dble( con(nzy) / log( con(nzy-1) / con(nzy) ) ) - !write (*,*) ' coninf =', coninf - -ccc -ccc temp dependence of the band strength and -ccc nlte correction factor for the absorber amount -ccc - call mztf_correccion ( coninf, con, ib, isot, itableout ) - -ccc -ccc reads histogrammed spectral data (strength for lte and vmr=1) -ccc - !hfile1 = dirspec//'hi'//dn !Ya no hacemos distincion d/n en esto -!! hfile1 = dirspec//'hid' !(see why in his.for) -! hfile1='hid' -!! if (ib.eq.13 .or. ib.eq.14 ) hfile1 = dirspec//'his' -! if (ib.eq.13 .or. ib.eq.14 ) hfile1 = 'his' - -! if(ib.eq.1.or.ib.eq.2.or.ib.eq.3.or.ib.eq.4.or.ib.eq.5 -! @ .or.ib.eq.6.or.ib.eq.7.or.ib.eq.8.or.ib.eq.9) then -! if (isot.eq.1) hisfile = hfile1//'26-'//ibcode1//'.dat' -! if (isot.eq.2) hisfile = hfile1//'28-'//ibcode1//'.dat' -! if (isot.eq.3) hisfile = hfile1//'36-'//ibcode1//'.dat' -! if (isot.eq.4) hisfile = hfile1//'27-'//ibcode1//'.dat' -! if (isot.eq.5) hisfile = hfile1//'62-'//ibcode1//'.dat' -! else -! if (isot.eq.1) hisfile = hfile1//'26-'//ibcode2//'.dat' -! if (isot.eq.2) hisfile = hfile1//'28-'//ibcode2//'.dat' -! if (isot.eq.3) hisfile = hfile1//'36-'//ibcode2//'.dat' -! if (isot.eq.4) hisfile = hfile1//'27-'//ibcode2//'.dat' -! if (isot.eq.5) hisfile = hfile1//'62-'//ibcode2//'.dat' -! endif -! write (*,*) 'hisfile: ', hisfile - -! the argument to rhist is to make this compatible with mztf_comp.f, -! which is a useful modification of mztf.f (to change strengths of bands -! call rhist (1.0) - if(ib.eq.1) then - if(isot.eq.1) then !Case 1 - mm=mm_c1 - nbox=nbox_c1 - tmin=tmin_c1 - tmax=tmax_c1 - do i=1,nbox_max - no(i)=no_c1(i) - dist(i)=dist_c1(i) - do j=1,nhist - sk1(j,i)=sk1_c1(j,i) - xls1(j,i)=xls1_c1(j,i) - xln1(j,i)=xln1_c1(j,i) - xld1(j,i)=xld1_c1(j,i) - enddo - enddo - do j=1,nhist - thist(j)=thist_c1(j) - enddo - else if(isot.eq.2) then !Case 2 - mm=mm_c2 - nbox=nbox_c2 - tmin=tmin_c2 - tmax=tmax_c2 - do i=1,nbox_max - no(i)=no_c2(i) - dist(i)=dist_c2(i) - do j=1,nhist - sk1(j,i)=sk1_c2(j,i) - xls1(j,i)=xls1_c2(j,i) - xln1(j,i)=xln1_c2(j,i) - xld1(j,i)=xld1_c2(j,i) - enddo - enddo - do j=1,nhist - thist(j)=thist_c2(j) - enddo - else if(isot.eq.3) then !Case 3 - mm=mm_c3 - nbox=nbox_c3 - tmin=tmin_c3 - tmax=tmax_c3 - do i=1,nbox_max - no(i)=no_c3(i) - dist(i)=dist_c3(i) - do j=1,nhist - sk1(j,i)=sk1_c3(j,i) - xls1(j,i)=xls1_c3(j,i) - xln1(j,i)=xln1_c3(j,i) - xld1(j,i)=xld1_c3(j,i) - enddo - enddo - do j=1,nhist - thist(j)=thist_c3(j) - enddo - else if(isot.eq.4) then !Case 4 - mm=mm_c4 - nbox=nbox_c4 - tmin=tmin_c4 - tmax=tmax_c4 - do i=1,nbox_max - no(i)=no_c4(i) - dist(i)=dist_c4(i) - do j=1,nhist - sk1(j,i)=sk1_c4(j,i) - xls1(j,i)=xls1_c4(j,i) - xln1(j,i)=xln1_c4(j,i) - xld1(j,i)=xld1_c4(j,i) - enddo - enddo - do j=1,nhist - thist(j)=thist_c4(j) - enddo - else - write(*,*)'isot must be 2,3 or 4 for ib=1!!' - write(*,*)'stop at mztvc/310' - stop - endif - else if (ib.eq.2) then - if(isot.eq.1) then !Case 5 - mm=mm_c5 - nbox=nbox_c5 - tmin=tmin_c5 - tmax=tmax_c5 - do i=1,nbox_max - no(i)=no_c5(i) - dist(i)=dist_c5(i) - do j=1,nhist - sk1(j,i)=sk1_c5(j,i) - xls1(j,i)=xls1_c5(j,i) - xln1(j,i)=xln1_c5(j,i) - xld1(j,i)=xld1_c5(j,i) - enddo - enddo - do j=1,nhist - thist(j)=thist_c5(j) - enddo - else - write(*,*)'isot must be 1 for ib=2!!' - write(*,*)'stop at mztvc/334' - stop - endif - else if (ib.eq.3) then - if(isot.eq.1) then !Case 6 - mm=mm_c6 - nbox=nbox_c6 - tmin=tmin_c6 - tmax=tmax_c6 - do i=1,nbox_max - no(i)=no_c6(i) - dist(i)=dist_c6(i) - do j=1,nhist - sk1(j,i)=sk1_c6(j,i) - xls1(j,i)=xls1_c6(j,i) - xln1(j,i)=xln1_c6(j,i) - xld1(j,i)=xld1_c6(j,i) - enddo - enddo - do j=1,nhist - thist(j)=thist_c6(j) - enddo - else - write(*,*)'isot must be 1 for ib=3!!' - write(*,*)'stop at mztvc/358' - stop - endif - else if (ib.eq.4) then - if(isot.eq.1) then !Case 7 - mm=mm_c7 - nbox=nbox_c7 - tmin=tmin_c7 - tmax=tmax_c7 - do i=1,nbox_max - no(i)=no_c7(i) - dist(i)=dist_c7(i) - do j=1,nhist - sk1(j,i)=sk1_c7(j,i) - xls1(j,i)=xls1_c7(j,i) - xln1(j,i)=xln1_c7(j,i) - xld1(j,i)=xld1_c7(j,i) - enddo - enddo - do j=1,nhist - thist(j)=thist_c7(j) - enddo - else - write(*,*)'isot must be 1 for ib=4!!' - write(*,*)'stop at mztvc/382' - stop - endif - else - write(*,*)'ib must be 1,2,3 or 4!!' - write(*,*)'stop at mztvc/387' - endif - - -c****** -c****** calculation of tau(1,ir) for 1<=r -c****** - call initial - - ff=1.0e10 - - in=1 - - tau(in,1) = 1.d0 - - call initial - call intz (zl(in), c1,p1,mr1,t1, con) - do kr=1,nbox - ta(kr) = t1 - end do - call interstrength (st1,t1,ka,ta) - do kr=1,nbox - c1box(kr) = c1 * ka(kr) * dble(deltaz) - end do - c1 = c1 * st1 * dble(deltaz) - - do 2 ir=2,nl - - call intz (zl(ir), c2,p2,mr2,t2, con) - do kr=1,nbox - ta(kr) = t2 - end do - call interstrength (st2,t2,ka,ta) - do kr=1,nbox - c2box(kr) = c2 * ka(kr) * dble(deltaz) - end do - c2 = c2 * st2 * dble(deltaz) - - aa = aa + ( p1*mr1*(c1*ff) + p2*mr2*(c2*ff)) / 2.d0 - bb = bb + ( p1*c1 + p2*c2 ) / 2.d0 - cc = cc + ( c1 + c2 ) / 2.d0 - dd = dd + ( t1*c1 + t2*c2 ) / 2.d0 - do kr=1,nbox - ccbox(kr) = ccbox(kr) + ( c1box(kr) + c2box(kr) ) /2.d0 - ddbox(kr) = ddbox(kr) + ( t1*c1box(kr) + t2*c2box(kr) ) /2.d0 - end do - - mr1=mr2 - t1=t2 - c1=c2 - p1=p2 - do kr=1,nbox - c1box(kr) = c2box(kr) - end do - - pt = bb / cc - pp = aa / (cc * ff) - - ts = dd/cc - do kr=1,nbox - ta(kr) = ddbox(kr) / ccbox(kr) - end do - call interstrength(st,ts,ka,ta) - call intershape(alsa,alna,alda,ta) - - - eqwmu = 0.0d0 - do im = 1,iimu - eqw=0.0d0 - do kr=1,nbox - ua(kr) = ccbox(kr) / ka(kr) * beta * 1.0d5 / mu(im) - call findw(ig,iirw, idummy,c1,p1,Desp,wsL) - if ( i_supersat .eq. 0 ) then - eqw=eqw+no(kr)*w - else - eqw = w + (no(kr)-1) * ( asat_box*dist(kr) ) - endif - end do - eqwmu = eqwmu + eqw * mu(im)*amu(im) - end do - - tau(in,ir) = exp( - eqwmu / dble(deltanu(isot,ib)) ) - - 2 continue - - - -c -c due to the simmetry of the transmittances -c - do in=nl,2,-1 - tau(in,1) = tau(1,in) - end do - - vc(1) = 0.0d0 - vc(nl) = 0.0d0 - do in=2,nl-1 ! poner aqui nl-1 luego - vc(in) = pi*deltanu(isot,ib)/( 2.d0*deltaz*1.d5 ) * - @ ( tau(in-1,1) - tau(in+1,1) ) - end do - - -c end - return - end Index: trunk/LMDZ.MARS/libf/phymars/mztvc_626fh.F =================================================================== --- trunk/LMDZ.MARS/libf/phymars/mztvc_626fh.F (revision 496) +++ (revision ) @@ -1,91 +1,0 @@ -c*********************************************************************** - - subroutine mztvc_626fh(ig) - -c jul 2011 malv+fgg -c*********************************************************************** - - implicit none - -!!!!!!!!!!!!!!!!!!!!!!! -! common variables & constants - - include 'nltedefs.h' - include 'nlte_atm.h' - include 'nlte_data.h' - include 'tcr_15um.h' - include 'nlte_matrix.h' - include 'nlte_curtis.h' - -!!!!!!!!!!!!!!!!!!!!!!! -! arguments - - integer ig ! ADDED FOR TRACEBACK - -!!!!!!!!!!!!!!!!!!!!!!! -! local variables - - real*4 cdummy(nl,nl), csngl(nl,nl) - - real*8 cax1(nl,nl), cax2(nl,nl), cax3(nl,nl) - real*8 v1(nl), v2(nl), v3(nl), cm_factor, vc_factor - - integer itauout,icfout,itableout, interpol,ismooth, isngldble - integer i,j,ik,ist,isot,ib,itt - - !character bandcode*2 - character isotcode*2 - !character codmatrx_hot*5 - -!!!!!!!!!!!!!!!!!!!!!!! -! external functions - - external bandid - character*2 bandid - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! subroutines called: -! mz4sub, dmzout, readc_mz4, readcupdw, mztf - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! formatos - 132 format(i2) - -************************************************************************ -************************************************************************ - - isngldble = 1 ! =1 --> dble precission - - fileroot = 'cfl' - - ist = 1 - isot = 26 - write (isotcode,132) isot - - call zerov( vc121, nl ) - - do 11, ik=1,3 - - ib=ik+1 - - call mztvc (ig,v1, ib, 1, irw_mztf, imu, 0,0,0 ) - - do i=1,nl - - if(ik.eq.1)then - vc_factor = dble(667.75/618.03) - elseif(ik.eq.2)then - vc_factor = 1.d0 - elseif(ik.eq.3)then - vc_factor = dble(667.75/720.806) - end if - - vc121(i) = vc121(i) + v1(i) * vc_factor - - end do - -11 continue - - - return - end Index: trunk/LMDZ.MARS/libf/phymars/nir_leedat.F =================================================================== --- trunk/LMDZ.MARS/libf/phymars/nir_leedat.F (revision 498) +++ trunk/LMDZ.MARS/libf/phymars/nir_leedat.F (revision 498) @@ -0,0 +1,38 @@ +c*********************************************************************** + subroutine NIR_leedat + +c reads parameters for NIR NLTE calculation + +c nov 2011 fgg+malv first version +c*********************************************************************** + + implicit none + + include 'datafile.h' + include 'nirdata.h' + + +c local variables + + integer ind + + +c*********************************************************************** + + open(43,file=trim(datafile)//'/NIRcorrection_feb2011.dat', + $ status='old') + do ind=1,9 + read(43,*) + enddo + + do ind=1,npres + read(43,*)pres1d(ind),corgcm(ind),oco21d(ind),p1999(ind), + $ alfa(ind) + !Tabulated pression to Pa + pres1d(ind)=pres1d(ind)*100. + enddo + close(43) + + return + + end Index: trunk/LMDZ.MARS/libf/phymars/nirco2abs.F =================================================================== --- trunk/LMDZ.MARS/libf/phymars/nirco2abs.F (revision 496) +++ trunk/LMDZ.MARS/libf/phymars/nirco2abs.F (revision 498) @@ -49,5 +49,5 @@ #include "callkeys.h" #include "comdiurn.h" -#include "NIRdata.h" +#include "nirdata.h" c----------------------------------------------------------------------- Index: trunk/LMDZ.MARS/libf/phymars/nirdata.h =================================================================== --- trunk/LMDZ.MARS/libf/phymars/nirdata.h (revision 498) +++ trunk/LMDZ.MARS/libf/phymars/nirdata.h (revision 498) @@ -0,0 +1,8 @@ + + integer npres ! Number of pressures in NIR correction + parameter (npres=42) ! table + + common /NIRdata/ pres1d,corgcm,oco21d,alfa,p1999 + real pres1d(npres) + real corgcm(npres) + real oco21d(npres),alfa(npres),p1999(npres) Index: trunk/LMDZ.MARS/libf/phymars/nlte_atm.h =================================================================== --- trunk/LMDZ.MARS/libf/phymars/nlte_atm.h (revision 496) +++ (revision ) @@ -1,40 +1,0 @@ -c**************************************************************************** -c -c atmref.cmn -c -c Common blocks of constants and variables for the model atmosphere -c -c jan 2007 Malv+gg Addition ions -c 2003 FGG Double precision -c JAN 98 MALV First version -c**************************************************************************** - - -c Subgrid atmosphere interpolated from /atmx/ actually used by the some -c modules, particularly by the NLTE ones -c - common /atm_nl/ zl, t, pl, sh, nt, co2, n2, co, o3p, o2, h2, ar, - @ co2vmr, n2vmr, covmr, o3pvmr, o2vmr, h2vmr, arvmr, - @ nvmr, novmr, - @ hrkday_factor - - real zl(nl), t(nl), pl(nl), nt(nl), sh(nl), - @ co2(nl), n2(nl), co(nl), o3p(nl), o2(nl), h2(nl), ar(nl), - @ co2vmr(nl), n2vmr(nl), covmr(nl), o3pvmr(nl), o2vmr(nl), - @ h2vmr(nl), arvmr(nl), - @ nvmr(nl), novmr(nl), hrkday_factor(nl) - -c Subgrid atmosphere obtained from the input atmosphere and limited to the -c NLTE grid. Only used for computing transmitances. -c - common /atm_ny/ zy, ty, py, nty, co2y, coy - real zy(nzy), ty(nzy), py(nzy), nty(nzy), co2y(nzy), coy(nzy) - -c - common/deltazetas/ deltaz, deltazy, - @ jlowerboundary, jtopboundary - real deltaz, deltazy - integer jlowerboundary, jtopboundary - - -c**************************************************************************** Index: trunk/LMDZ.MARS/libf/phymars/nlte_aux.F =================================================================== --- trunk/LMDZ.MARS/libf/phymars/nlte_aux.F (revision 498) +++ trunk/LMDZ.MARS/libf/phymars/nlte_aux.F (revision 498) @@ -0,0 +1,2023 @@ +c*********************************************************************** +c File with all subroutines required by mztf +c Subroutines previously included in mztfsub_overlap.F +c +c jan 98 malv basado en mztfsub_solar +c jul 2011 malv+fgg adapted to LMD-MGCM +c +c contiene: +c initial +c intershape +c interstrength +c intz +c rhist +c we +c simrul +c fi +c f +c findw +c voigtf +c*********************************************************************** + +c **************************************************************** + subroutine initial + +c ma & crs !evita troubles 16-july-96 +c **************************************************************** + + implicit none + + include 'nlte_paramdef.h' + include 'nlte_commons.h' + +c local variables + integer i + +c *************** + + eqw = 0.0d00 + aa = 0.0d00 + bb = 0.0d00 + cc = 0.0d00 + dd = 0.0d00 + + do i=1,nbox + ua(i) = 0.0d0 + ccbox(i) = 0.0d0 + ddbox(i) = 0.0d0 + end do + + return + end + +c ********************************************************************** + subroutine intershape(alsx,alnx,adx,xtemp) +c interpolates the line shape parameters at a temperature xtemp from +c input histogram data. +c ********************************************************************** + + implicit none + + include 'nlte_paramdef.h' + include 'nlte_commons.h' + +c arguments + real*8 alsx(nbox_max),alnx(nbox_max),adx(nbox_max), + & xtemp(nbox_max) + +c local variables + integer i, k + +c *********** + +! write (*,*) 'intershape xtemp =', xtemp + + do 1, k=1,nbox + if (xtemp(k).gt.tmax) then + write (*,*) ' WARNING ! Tpath,tmax= ',xtemp(k),tmax + xtemp(k) = tmax + endif + if (xtemp(k).lt.tmin) then + write (*,*) ' WARNING ! Tpath,tmin= ',xtemp(k),tmin + xtemp(k) = tmin + endif + + i = 1 + do while (i.le.mm) + i = i + 1 + + if (abs(xtemp(k)-thist(i)) .lt. 1.0d-4) then !evita troubles + alsx(k)=xls1(i,k) !16-july-1996 + alnx(k)=xln1(i,k) + adx(k)=xld1(i,k) + goto 1 + elseif ( thist(i) .le. xtemp(k) ) then + alsx(k) = (( xls1(i,k)*(thist(i-1)-xtemp(k)) + + @ xls1(i-1,k)*(xtemp(k)-thist(i)) )) / + $ (thist(i-1)-thist(i)) + alnx(k) = (( xln1(i,k)*(thist(i-1)-xtemp(k)) + + @ xln1(i-1,k)*(xtemp(k)-thist(i)) )) / + $ (thist(i-1)-thist(i)) + adx(k) = (( xld1(i,k)*(thist(i-1)-xtemp(k)) + + @ xld1(i-1,k)*(xtemp(k)-thist(i)) )) / + $ (thist(i-1)-thist(i)) + goto 1 + end if + end do + write (*,*) + @ ' error in xtemp(k). it should be between tmin and tmax' + 1 continue + + return + end +c ********************************************************************** + subroutine interstrength (stx, ts, sx, xtemp) +c interpolates the line strength at a temperature xtemp from +c input histogram data. +c ********************************************************************** + + implicit none + + include 'nlte_paramdef.h' + include 'nlte_commons.h' + +c arguments + real*8 stx ! output, total band strength + real*8 ts ! input, temp for stx + real*8 sx(nbox_max) ! output, strength for each box + real*8 xtemp(nbox_max) ! input, temp for sx + +c local variables + integer i, k + +c *********** + + do 1, k=1,nbox +! if(xtemp(k).lt.ts)then +! write(*,*)'***********************' +! write(*,*)'mztfsub_overlap/EEEEEEH!',xtemp(k),ts,k +! write(*,*)'***********************' +! endif + if (xtemp(k).gt.tmax) xtemp(k) = tmax + if (xtemp(k).lt.tmin) xtemp(k) = tmin + i = 1 + do while (i.le.mm-1) + i = i + 1 +! write(*,*)'mztfsub_overlap/136',i,xtemp(k),thist(i) + if ( abs(xtemp(k)-thist(i)) .lt. 1.0d-4 ) then + sx(k) = sk1(i,k) +! write(*,*)'mztfsub_overlap/139',sx(k),k,i + goto 1 + elseif ( thist(i) .le. xtemp(k) ) then + sx(k) = ( sk1(i,k)*(thist(i-1)-xtemp(k)) + sk1(i-1,k)* + @ (xtemp(k)-thist(i)) ) / (thist(i-1)-thist(i)) +! write(*,*)'mztfsub_overlap/144',sx(k),k,i + goto 1 + end if + end do + write (*,*) ' error in xtemp(kr) =', xtemp(k), + @ '. it should be between ' + write (*,*) ' tmin =',tmin, ' and tmax =',tmax + stop + 1 continue + + stx = 0.d0 + if (ts.gt.tmax) ts = dble( tmax ) + if (ts.lt.tmin) ts = dble( tmin ) + i = 1 + do while (i.le.mm-1) + i = i + 1 +! write(*,*)'mztfsub_overlap/160',i,ts,thist(i) + if ( abs(ts-thist(i)) .lt. 1.0d-4 ) then + do k=1,nbox + stx = stx + no(k) * sk1(i,k) +! write(*,*)'mztfsub_overlap/164',stx + end do + return + elseif ( thist(i) .le. ts ) then + do k=1,nbox + stx = stx + no(k) * (( sk1(i,k)*(thist(i-1)-ts) + + @ sk1(i-1,k)*(ts-thist(i)) )) / (thist(i-1)-thist(i)) +! write(*,*)'mztfsub_overlap/171',stx + end do +! stop + return + end if + end do + + return + end + + +c ********************************************************************** + subroutine intz(h,aco2,ap,amr,at, con) +c return interp. concentration, pressure,mixing ratio and temperature +c for a input height h +c ********************************************************************** + + implicit none + include 'nlte_paramdef.h' + include 'nlte_commons.h' + +c arguments + real h ! i + real*8 con(nzy) ! i + real*8 aco2, ap, at, amr ! o + +c local variables + integer k + +c ************ + + if ( ( h.lt.zy(1) ).and.( h.le.-1.e-5 ) ) then + write (*,*) ' zp= ',h,' zy(1)= ',zy(1) + stop'from intz: error in interpolation, z < minimum height' + elseif (h.gt.zy(nzy)) then + write (*,*) ' zp= ',h,' zy(nzy)= ',zy(nzy) + stop'from intz: error in interpolation, z > maximum height' + end if + + if (h.eq.zy(nzy)) then + ap = dble( py(nzy) ) + aco2= con(nzy) + at = dble( ty(nzy) ) + amr = dble( mr(nzy) ) + return + end if + + do k=1,nzy-1 + if( abs( h-zy(k) ).le.( 1.e-5 ) ) then + ap = dble( py(k) ) + aco2= con(k) + at = dble( ty(k) ) + amr = dble( mr(k) ) + return + elseif(h.gt.zy(k).and.h.lt.zy(k+1))then + ap = dble( exp( log(py(k)) + log(py(k+1)/py(k)) * + @ (h-zy(k)) / (zy(k+1)-zy(k)) ) ) + aco2 = exp( log(con(k)) + log( con(k+1)/con(k) ) * + @ (h-zy(k)) / (zy(k+1)-zy(k)) ) + at = dble( ty(k)+(ty(k+1)-ty(k))*(h-zy(k))/ + @ (zy(k+1)-zy(k)) ) + amr = dble( mr(k)+(mr(k+1)-mr(k))*(h-zy(k))/ + @ (zy(k+1)-zy(k)) ) + return + end if + end do + + return + end + + + +c ********************************************************************** + real*8 function we(ig,me,pe,plaux,idummy,nt_local,p_local, + $ Desp,wsL) +c icls=5 -->para mztf +c icls=1,2,3-->para fot, line shape (v=1,l=2,d=3) (only use if wr=2) +c calculates an approximate equivalent width for an error estimate. +c +c ioverlap = 0 ....... no correction for overlaping +c 1 ....... "lisat" first correction (see overlap_box. +c 2 ....... " " " plus "supersaturation" + +c idummy=0 do nothing +c 1 write out some values for diagnostics +c 2 correct the Strong Lorentz behaviour for SZA>90 +c 3 casos 1 & 2 + +c malv nov-98 add overlaping's corrections +c ********************************************************************** + + implicit none + + include 'nlte_paramdef.h' + include 'nlte_commons.h' + +c arguments + integer ig ! ADDED FOR TRACEBACK + real*8 me ! I. path's absorber amount + real*8 pe ! I. path's presion total + real*8 plaux ! I. path's partial pressure of CO2 + real*8 nt_local ! I. needed for strong limit of Lorentz profil + real*8 p_local ! I. " " " + integer idummy ! I. indica varias opciones + real*8 wsL ! O. need this for strong Lorentz correction + real*8 Desp ! I. need this for strong Lorentz correction + +c local variables + integer i + real*8 y,x,wl,wd + real*8 cn(0:7),dn(0:7) + real*8 pi, xx + real*8 f_sat_box + real*8 dv_sat_box, dv_corte_box + real*8 area_core_box, area_wing_box + real*8 wlgood , parentesis , xlor + real*8 wsl_grad + + +c data blocks + data cn/9.99998291698d-1,-3.53508187098d-1,9.60267807976d-2, + @ -2.04969011013d-2,3.43927368627d-3,-4.27593051557d-4, + @ 3.42209457833d-5,-1.28380804108d-6/ + data dn/1.99999898289,5.774919878d-1,-5.05367549898d-1, + @ 8.21896973657d-1,-2.5222672453,6.1007027481, + @ -8.51001627836,4.6535116765/ + +c *********** + +c equivalent width of atmospheric line. + + pi = acos(-1.d0) + + if ( idummy.gt.9 ) + @ write (*,*) ' S, m, alsa, pp =', ka(kr), me, alsa(kr), plaux + + y=ka(kr)*me +! x=y/(2.0*pi*(alsa(kr)*pl+alna(kr)*(pe-pl))) + x=y/(2.0d0*pi* alsa(kr)*plaux) !+alna(kr)*(pe-pl))) + +! Strong limit of Lorentz profile: WL = 2 SQRT( S * m * alsa*pl ) +! Para anular esto, comentar las siguientes 5 lineas +! if ( x .gt. 1.e6 ) then +! wl = 2.0*sqrt( y * alsa(kr)*pl ) +! else +! wl=y/sqrt(1.0d0+pi*x/2.0d0) +! endif + + wl=y/sqrt(1.0d0+pi*x/2.0d0) + + if (wl .le. 0.d0) then + write(*,*)'mztfsub_overlap/496',ig,y,ka(kr),me,kr + stop'WE/Lorentz EQW zero or negative!/498' !,ig + endif + + if ( idummy.gt.9 ) + @ write (*,*) ' y, x =', y, x + + xlor = x + if ( (idummy.eq.2 .or. idummy.eq.12) .and. xlor.gt.1e5 ) then + ! en caso que estemos en el regimen + ! Strong Lorentz y la presion local + ! vaya disminuyendo, corregimos la EQW + ! con un gradiente analitico (notebook) + wsL = 2.0*sqrt( y * alsa(kr)*plaux ) + wsl_grad = - 2.d0 * ka(kr)*alsa(kr) * nt_local*p_local / wsL + wlgood = w_strongLor_prev(kr) + wsl_grad * Desp + if (idummy.eq.12) + @ write (*,*) ' W(wrong), W_SL, W_SL prev, W_SL corrected=', + @ wl, wsL, w_strongLor_prev(kr), wlgood + wl = wlgood + endif + ! wsL = wl pero esto no lo hacemos todavia, porque necesitamos + ! el valor que ahora mismo tiene wsL para corregir la + ! expresion R&W below + +! write (*,*) 'WE arguments me,pe,pl =', me,pe,pl +! write (*,*) 'WE/ wl,ka(kr),alsa(kr) =', +! @ wl, ka(kr),alsa(kr) + + +!>>>>>>> + 500 format (a,i3,3(2x,1pe15.8)) + 600 format (a,2(2x,1pe16.9)) + 700 format (a,3(1x,1pe16.9)) +! if (kr.eq.8 .or. kr.eq.13) then +! write (*,500) 'WE/kr,m,pt,pl=', kr, me, pe, pl +! write (*,700) ' /aln,als,d_x=', alna(kr),alsa(kr), +! @ 2.0*pi*( alsa(kr)*pl + alna(kr)*(pe-pl) ) +! write (*,600) ' /alsa*p_CO2, alna*p_n2 :', +! @ alsa(kr)*pl, alna(kr)*(pe-pl) +! write (*,600) ' a*p, S =', +! @ alsa(kr)*pl + alna(kr)*(pe-pl) , ka(kr) +! write (*,600) ' /S*m, x =', y, x +! write (*,600) ' /aprox, WL =', +! @ 2.*sqrt( y*( alsa(kr)*pl+alna(kr)*(pe-pl) ) ), WL +! endif + ! + ! corrections to lorentz eqw due to overlaping and super-saturation + ! + + i_supersat = 0 + + if ( icls.eq.5 .and. ioverlap.gt.0 ) then + ! for the moment, only consider overlaping for mztf.f, not fot.f + + ! definition of saturation in the lisat model + ! + asat_box = 0.99d0 + f_sat_box = 2.d0 * x + xx = f_sat_box / log( 1./(1-asat_box) ) + if ( xx .lt. 1.0d0 ) then + dv_sat_box = 0.0d0 + asat_box = 1.0d0 - exp( - f_sat_box ) + else + dv_sat_box = alsa(kr) * sqrt( xx - 1.0d0 ) + ! approximation: only use of alsa in mars and venus + endif + + ! area of saturated line + ! + area_core_box = 2.d0 * dv_sat_box * asat_box + area_wing_box = 0.5d0 * ( wl - area_core_box ) + dv_corte_box = dv_sat_box + 2.d0*area_wing_box/asat_box + + ! super-saturation or simple overlaping? + ! +! i_supersat = 0 + xx = dv_sat_box - ( 0.5d0 * dist(kr) ) + if ( xx .ge. 0.0 ! definition of supersaturation + @ .and. dv_sat_box .gt. 0.0 ! definition of saturation + @ .and. (dist(kr).gt.0.0) ) ! box contains more than 1 line + @ ! and not too far apart + @ then + + i_supersat = 1 + + else + ! no super-saturation, then use "lisat + first correction", i.e., + ! correct for line products + ! + + wl = wl + + endif + + end if ! end of overlaping loop + + if (icls.eq.2) then + we = wl + return + endif + +cc doppler limit: + if ( idummy.gt.9 ) + @ write (*,*) ' S*m, alf_dop =', y, alda(kr)*sqrt(pi) + + x = y / (alda(kr)*sqrt(pi)) + if ( x.lt.1.e-10 ) then ! to avoid underflow + wd = y + else + wd=alda(kr)*sqrt(4.0*pi*x**2*(1.0+log(1.0+x))/(4.0+pi*x**2)) + endif + if ( idummy.gt.9 ) + @ write (*,*) ' wd =', wd + +cc doppler weak limit +c wd = ka(kr) * me + +cc good doppler + if(icls.eq.5) then !para mztf + !write (*,*) 'para mztf, icls=',icls + if (x.lt.5.) then + wd = 0.d0 + do i=0,7 + wd = wd + cn(i) * x**i + end do + wd = alda(kr) * x * sqrt(pi) * wd + elseif (x.gt.5.) then + wd = 0.d0 + do i=0,7 + wd = wd + dn(i) / (log(x))**i + end do + wd = alda(kr) * sqrt(log(x)) * wd + else + stop ' x should not be less than zero' + end if + end if + + + if ( i_supersat .eq. 0 ) then + + parentesis = wl**2+wd**2-(wd*wl/y)**2 + ! changed +(wd*wl/y)**2 to -...14-3-84 + + if ( parentesis .lt. 0.0 ) then + if ((idummy.eq.2 .or. idummy.eq.12) .and. xlor.gt.1e5) then + parentesis = wl**2+wd**2-(wd*wsL/y)**2 + ! este cambio puede ser necesario cuando se hace + ! correccion Strong Lor, para evitar valores + ! negativos del parentesis en sqrt( ) + else + stop ' WE/ Error en las EQW wl,wl,y ' + endif + endif + + we = sqrt( parentesis ) +! write (*,*) ' from we: xdop,alda,wd', sngl(x),alda(kr),sngl(wd) +! write (*,*) ' from we: we', we + + else + + we = wl + ! if there is supersaturation we can ignore wd completely; + ! mztf.f will compute the eqw of the whole box afterwards + + endif + + if (icls.eq.3) we = wd + + if ( idummy.gt.9 ) + @ write (*,*) ' wl,wd,w =', wl,wd,we + + wsL = wl + + return + end + + +c ********************************************************************** + real*8 function simrul(a,b,fsim,c,acc) +c adaptively integrates fsim from a to b, within the criterion acc. +c ********************************************************************** + + implicit none + + real*8 res,a,b,g0,g1,g2,g3,g4,d,a0,a1,a2,h,x,acc,c,fsim + real*8 s1(70),s2(70),s3(70) + real*8 c1, c2 + integer*4 m,n,j + + res=0. + c=0. + m=0 + n=0 + j=30 + g0=fsim(a) + g2=fsim((a+b)/2.) + g4=fsim(b) + a0=(b-a)*(g0+4.0*g2+g4)/2.0 + 1 d=2.0**n + h=(b-a)/(4.0*d) + x=a+(4.0*m+1.0)*h + g1=fsim(x) + g3=fsim(x+2.0*h) + a1=h*(g0+4.0*g1+g2) + a2=h*(g2+4.0*g3+g4) + if ( abs(a1+a2-a0).gt.(acc/d)) goto 2 + res=res+(16.0*(a1+a2)-a0)/45.0 + m=m+1 + c=a+m*(b-a)/d + 6 if (m.eq.(2*(m/2))) goto 4 + if ((m.ne.1).or.(n.ne.0)) goto 5 + 8 simrul=res + return + 2 m=2*m + n=n+1 + if (n.gt.j) goto 3 + a0=a1 + s1(n)=a2 + s2(n)=g3 + s3(n)=g4 + g4=g2 + g2=g1 + goto 1 + 3 c1=c-(b-a)/d + c2=c+(b-a)/d + write(2,7) c1,c,c2,fsim(c1),fsim(c),fsim(c2) + write(*,7) c1,c,c2,fsim(c1),fsim(c),fsim(c2) + 7 format(2x,17hsimrule fails at ,/,3e15.6,/,3e15.6) + goto 8 + 5 a0=s1(n) + g0=g4 + g2=s2(n) + g4=s3(n) + goto 1 + 4 m=m/2 + n=n-1 + goto 6 + end + +c ********************************************************************** + subroutine findw(ig,iirw,idummy,c1,p1, Desp, wsL) +c this routine sets up accuracy criteria and calls simrule between limit +c that depend on the number of atmospheric and cell paths. it gives eqw. + +c Add correction for EQW in Strong Lorentz regime and SZA>90 +c ********************************************************************** + + implicit none + include 'nlte_paramdef.h' + include 'nlte_commons.h' + +c arguments + integer ig ! ADDED FOR TRACEBACK + integer iirw + integer idummy ! I. indica varias opciones + real*8 c1 ! I. needed for strong limit of Lorentz profil + real*8 p1 ! I. " " " + real*8 wsL ! O. need this for strong Lorentz correction + real*8 Desp ! I. need this for strong Lorentz correction + +c local variables + real*8 ept,eps,xa + real*8 acc, c + real*8 we + real*8 f, fi, simrul + + external f,fi + +c ********** *********** ********* + + if(icls.eq.5) then !para mztf +! if(ig.eq.1682)write(*,*)'mztfsub_overlap/768',ua(kr),iirw + if (iirw.eq.2) then !iirw=icf=2 ==> we use the w&r formula + w = we(ig,ua(kr),pt,pp, idummy, c1,p1, Desp, wsL ) + return + end if + ept=we(ig,ua(kr),pt,pp, idummy,c1,p1, Desp, wsL) + else !para fot + if (iirw.eq.2) then ! icf=2 ==> we use the w&r formula + w = we(ig,sl_ua,pt,pp, idummy,c1,p1, Desp, wsL) + return + end if + ept=we(ig,sl_ua,pt,pp, idummy,c1,p1, Desp, wsL) + end if + +c the next block is a modification to avoid nul we. +c this situation appears for weak lines and low path temperature, but +c there is not any loss of accuracy. first july 1986 + if (ept.eq.0.) then ! for weak lines sometimes we=0 + ept=1.0e-18 + write (*,*) 'ept =',ept + write (*,*) 'from we: we=0.0' + return + end if + + acc = 4.d0 + acc = 10.d0**(-acc) + + eps = acc * ept !accuracy 10-4 atmospheric eqw. + xa=0.5*ept/f(0.d0) !width of doppler shifted atmospheric line. + w=2.0*(simrul(0.0d0,xa,f,c,eps)+simrul(0.1d0,1.0/xa,fi,c,eps)) +!no shift. + + return + end + + +c ********************************************************************** + double precision function fi(y) +c returns the value of f(1/y) +c ********************************************************************** + + implicit none + real*8 f, y + + fi=f(1.0/y)/y**2 + return + end + + +c ********************************************************************** + double precision function f(nuaux) +c calculates 1-exp(-k(nu)u) for all series paths or combinations thereof +c ********************************************************************** + + implicit none + include 'nlte_paramdef.h' + include 'nlte_commons.h' + + double precision tra,xa,ya,za,yy,nuaux + double precision voigtf + tra=1.0d0 + + yy=1.0d0/alda(kr) + xa=nuaux*yy + ya= ( alsa(kr)*pp + alna(kr)*(pt-pp) ) * yy + za=ka(kr)*yy + + if(icls.eq.5) then !para mztf + ! write (*,*) 'icls=',icls + tra=za*ua(kr)*voigtf(sngl(xa),sngl(ya)) + else + tra=za*sl_ua*voigtf(sngl(xa),sngl(ya)) + end if + + if (tra.gt.50.0) then + tra=1.0 !2.0e-22 overflow cut-off. + else if (tra.gt.1.0e-4) then + tra=1.0-exp(-tra) + end if + + f=tra + return + end + +c ********************************************************************** + double precision function voigtf(x1,y) +c computes voigt function for any value of x1 and any +ve value of y. +c where possible uses modified lorentz and modified doppler approximatio +c otherwise uses a rearranged rybicki routine. +c c(n) = exp(-(n/h)**2)/(pi*sqrt(pi)), with h = 2.5 . +c accurate to better than 1 in 10000. +c ********************************************************************** + + implicit none + + real x1, y + real x, xx, xxyy, xh,xhxh, yh,yhyh, f1,f2, p, q, xn,xnxn, voig + + real*8 b,g0,g1,g2,g3,g4,d1,d2,d3,d4,c + integer*4 n + + dimension c(10) + complex xp,xpp,z + + data c(1)/0.15303405/ + data c(2)/0.94694928e-1/ + data c(3)/0.42549174e-1/ + data c(4)/0.13882935e-1/ + data c(5)/0.32892528e-2/ + data c(6)/0.56589906e-3/ + data c(7)/0.70697890e-4/ + data c(8)/0.64135678e-5/ + data c(9)/0.42249221e-6/ + data c(10)/0.20209868e-7/ + + x=abs(x1) + if (x.gt.7.2) goto 1 + if ((y+x*0.3).gt.5.4) goto 1 + if (y.gt.0.01) goto 3 + if (x.lt.2.1) goto 2 + goto 3 +c here uses modified lorentz approx. + 1 xx=x*x + xxyy=xx+y*y + b=xx/xxyy + voigtf=y*(1.+(2.*b-0.5+(0.75-(9.-12.*b)*b)/xxyy)/ + * xxyy)/(xxyy*3.141592654) + return +c here uses modified doppler approx. + 2 xx=x*x + voigtf=0.56418958*exp(-xx)*(1.-y*(1.-0.5*y)*(1.1289-xx*(1.1623+ + * xx*(0.080812+xx*(0.13854-xx*(0.033605-0.0073972*xx)))))) + return +c here uses a rearranged rybicki routine. + 3 xh=2.5*x + xhxh=xh*xh + yh=2.5*y + yhyh=yh*yh + f1=xhxh+yhyh + f2=f1-0.5*yhyh + if (y.lt.0.1) goto 20 + p=-y*7.8539816 !7.8539816=2.5*pi + q=x*7.8539816 + xpp=cmplx(p,q) + z=cexp(xpp) + d1=xh*aimag(z) + d2=-d1 + d3=yh*(1.-real(z)) + d4=-d3+2.*yh + voig=0.17958712*(d1+d3)/f1 + goto 30 + 20 p=x*7.8539816 + q=y*7.8539816 + xp=cmplx(p,q) + z=ccos(xp) + d1=xh*aimag(z) + d2=-d1 + d3=yh*(1.-real(z)) + d4=-d3+2.*yh + voig=0.56418958*exp(y*y-x*x)*cos(2.*x*y)+0.17958712*(d1+d3)/f1 + 30 xn=0. + do 55 n=1,10,2 + xn=xn+1. + xnxn=xn*xn + g1=xh-xn + g2=g1*(xh+xn) + g3=0.5*g2*g2 + voig=voig+c(n)*(d2*(g2+yhyh)+d4*(f1+xnxn))/ + & (g3+yhyh*(f2+xnxn)) + xn=xn+1. + xnxn=xn*xn + g1=xh-xn + g2=g1*(xh+xn) + g3=0.5*g2*g2 + voig=voig+c(n+1)*(d1*(g2+yhyh)+d3*(f1+xnxn))/ + @ (g3+yhyh*(f2+xnxn)) + 55 continue + voigtf=voig + return + end + + + +c ********************************************************************** +c elimin_mz1d.F (includes smooth_cf) +c ************************************************************************ + subroutine elimin_mz1d (c,vc, ilayer,nanaux,itblout, nwaux) + +c Eliminate anomalous negative numbers in c(nl,nl) according to "nanaux": + +c nanaux = 0 -> no eliminate +c @ -> eliminate all numbers with absol.value eliminate all anomalous negative numbers in c(n,r). +c 3 -> eliminate all anomalous negative numbers far from the main +c diagonal. +c 8 -> eliminate all non-zero numbers outside the main diagonal, +c and the contibution of lower boundary. +c 9 -> eliminate all non-zero numbers outside the main diagonal. +c 4 -> hace un smoothing cuando la distancia de separacion entre +c el valor maximo y el minimo de cf > 50 capas. +c 5 -> elimina valores menores que 1.0d-19 +c 6 -> incluye los dos casos 4 y 5 +c 7 -> llama a lisa: smooth con width=nw & elimina mejorado +c 78-> incluye los dos casos 7 y 8 +c 79-> incluye los dos casos 7 y 9 + +c itblout (itableout in calling program) is the option for writing +c out or not the purged c(n,r) matrix: +c itblout = 0 -> no write +c = 1 -> write out in curtis***.out according to ilayer + +c ilayer is the index for the layer selected to write out the matrix: +c ilayer = 0 => matrix elements written out cover all the altitudes +c with 5 layers steps +c > 0 => " " " " are c(ilayer,*) +c NOTA: +c EXISTE LA POSIBILIDAD DE SACAR TODAS LAS CAPAS (TODA LA MATRIZ) +c UTILIZANDO itableout=30 EN MZTUD + +c jul 2011 malv+fgg adapted to LMD-MGCM +c Sep-04 FGG+MALV Correct include and call parameters +c cristina 25-sept-1996 y 27-ene-1997 +c JAN 98 MALV Version for mz1d +c ************************************************************************ + + implicit none + + include 'nlte_paramdef.h' + include 'nlte_commons.h' + + integer nanaux,j,i,itblout,kk,k,ir,in + integer ilayer,jmin, jmax,np,nwaux,ntimes,ntimes2 +!* real*8 c(nl,nl), vc(nl), amax, cmax, cmin, cs(nl,nl), mini + real*8 c(nl,nl), vc(nl), amax, cmax, cmin, mini + real*8 aux(nl), auxs(nl) + character layercode*3 + + ntimes=0 + ntimes2=0 +! type *,'from elimin_mz4: nan, nw',nan,nw + + if (nanaux .eq. 0) goto 200 + + if(nanaux.eq.1)then + do i=1,nl + amax=1.0d-36 + do j=1,nl + if(abs(c(i,j)).gt.amax)amax=abs(c(i,j)) + end do + do j=1,nl + if(abs(c(i,j)).lt.amax/300.0d0)c(i,j)=0.0d0 + end do + enddo + elseif(nanaux.eq.2)then + do i=1,nl + do j=1,nl + if( ( j.le.(i-2) .or. j.gt.(i+2) ).and. + @ ( c(i,j).lt.0.0d0 ) ) c(i,j)=0.0d0 + end do + enddo + elseif(nanaux.eq.3)then + do i=1,nl + do j=1,nl + if (abs(i-j).ge.10) c(i,j)=0.0d0 + end do + enddo + elseif(nanaux.eq.8)then + do i=1,nl + do j=1,i-1 + c(i,j)=0.0d0 + enddo + do j=i+1,nl + c(i,j)=0.0d0 + enddo + vc(i)= 0.d0 + enddo + elseif(nanaux.eq.9)then + do i=1,nl + do j=1,i-1 + c(i,j)=0.0d0 + enddo + do j=i+1,nl + c(i,j)=0.0d0 + enddo + enddo +! elseif(nan.eq.7.or.nan.eq.78.or.nan.eq.79)then +! call lisa(c, vc, nl, nw) + end if + if(nanaux.eq.78)then + do i=1,nl + do j=1,i-1 + c(i,j)=0.0d0 + enddo + do j=i+1,nl + c(i,j)=0.0d0 + enddo + vc(i)= 0.d0 + enddo + endif + if(nanaux.eq.79)then + do i=1,nl + do j=1,i-1 + c(i,j)=0.0d0 + enddo + do j=i+1,nl + c(i,j)=0.0d0 + enddo + enddo + endif + + if(nanaux.eq.5.or.nanaux.eq.6)then + do i=1,nl + mini = 1.0d-19 + do j=1,nl + if(abs(c(i,j)).le.mini.and.c(i,j).ne.0.d0) then + ntimes2=ntimes2+1 + end if + if ( abs(c(i,j)).le.mini) c(i,j)=0.d0 + end do + enddo + end if + + if(nanaux.eq.4.or.nanaux.eq.6)then + do i=1,nl + do j=1,nl + aux(j)=c(i,j) + auxs(j)=c(i,j) + end do + !call maxdp_2(aux,nl,cmax,jmax) + cmax=maxval(aux) + jmax=maxloc(aux,dim=1) + if(abs(jmax-i).ge.50) then + call smooth_cf(aux,auxs,i,nl,3) + !!!call smooth_cf(aux,auxs,i,nl,5) + ntimes=ntimes+1 + end if + do j=1,nl + c(i,j)=auxs(j) + end do + end do + end if + +! type *, 'elimin_mz4: c(n,r) procesed for elimination. ' +! type *, ' ' +! if(nan.eq.4.or.nan.eq.6) type *, ' call smoothing:',ntimes +! if(nan.eq.5.or.nan.eq.6) type *, ' call elimina: ',ntimes2 +! if(nan.eq.7) type *, ' from elimin: lisa w=',nw +! type *, ' ' + + + 200 continue + +c writting out of c(n,r) in ascii file + +! if(itblout.eq.1) then + +! if (ilayer.eq.0) then + +! open (unit=2, status='new', +! @ file=dircurtis//'curtis_gnu.out', recl=1024) +! write(2,'(a)') +! @ ' curtis matrix: table with 1.e+7 * acf(n,r) ' +! write(2,114) 'n,r', ( i, i=nl,1,-5 ) +! do in=nl,1,-5 +! write(2,*) +! write(2,115) in, ( c(in,ir)*1.d7, ir=nl,1,-5 ) +! end do +! close(2) + + +! write (*,*) ' ' +! write (*,*) ' curtis.out has been created. ' +! write (*,*) ' ' + +! else + +! write (layercode,132) ilayer +! open (2, status='new', +! @ file=dircurtis//'curtis'//layercode//'.out') +! write(2,'(a)') +! @ ' curtis matrix: table with 1.e+7 * acf(n,r) ' +! write(2,116) ' layer x c(',layercode, +! @ ',x) c(x,', layercode,')' +! do in=nl,1,-1 +! if (c(ilayer,ilayer).ne.0.d0) then +! write(2,117) in, c(ilayer,in), c(in,ilayer), +! @ c(ilayer,in)/c(ilayer,ilayer), +! @ c(in,ilayer)/c(ilayer,ilayer) +! else +! write(2,118) in, c(ilayer,in), c(in,ilayer) +! end if +! end do +! close(2) +! write (*,*) ' ' +! write (*,*) dircurtis//'curtis'//layercode//'.out', +! @ ' has been created.' +! write (*,*) ' ' + +! end if + +! elseif(itblout.eq.0)then + +! continue + +! else + +! write (*,*) ' error from elimin: ', +! @ ' itblout should be 1 or 0; itblout= ',itblout +! stop + +! end if + + return + + 112 format(10x,10(i3,9x)) + 113 format(1x,i3,2x,9(1pe9.2,2x)) + + 114 format(1x,a3, 11(8x,i3)) + 115 format( 1x,i3, 2x, 11(1pe10.3)) + 116 format( 1x,a17,a2,a18,a2,a1 ) + 117 format( 3x,i3, 4(8x,1pe10.3) ) + 118 format( 3x,i3, 2(8x,1pe10.3) ) + 120 format( 1x,i3, 1x,i3, 2x, 11(1pe10.3)) + + 132 format(i3) + +! cambio: los formatos 114, 115 , 117 y 118 +! cambio: al cambia nl de 51 a 140 hay que cambiar el formato i2-->i3 +! y ahora en vez de 11 capas de 5 en 5, hay 28 +! + end +c************************************************************************** + subroutine smooth_cf( c, cs, i, nl, w ) +c hace un smoothing de c(i,*), de la contribucion de todas las capas +c menos de la capa en cuestion, la i. +c opcion w (width): el tamanho de la ventana del smoothing. +c output values: cs +c************************************************************************** + + implicit none + + integer j,np,i,nl,w + real*8 c(nl), cs(nl) + + if(w.eq.0) then + do j=1,nl + cs(j)=c(j) + end do + + elseif(w.eq.3) then + +! write (*,*) 'smoothing w=3' + do j=1,i-4 + if(j.eq.1) then + cs(j)=c(j) + else + cs(j)=1/3.d0*(c(j-1)+c(j)+c(j+1)) + end if + end do + do j=i+4,nl-1 + if(j.eq.nl) then + cs(j)=c(j) + else + cs(j)=1/3.d0*(c(j-1)+c(j)+c(j+1)) + end if + end do + elseif(w.eq.5) then + +! type *,'smoothing w=5' + do j=3,i-4 + if(j.eq.1) then + cs(j)=c(j) + else + cs(j)=1/5.d0*(c(j-2)+c(j-1)+c(j)+c(j+1)+c(j+2)) + end if + end do + do j=i+4,nl-2 + if(j.eq.nl) then + cs(j)=c(j) + else + cs(j)=1/5.d0*(c(j-2)+c(j-1)+c(j)+c(j+1)+c(j+2)) + end if + end do + end if + return + end + + + +c***************************************************************************** +c suaviza +c***************************************************************************** +c + subroutine suaviza ( x, n, ismooth, y ) +c +c x - input and return values +c y - auxiliary vector +c ismooth = 0 --> no smoothing is performed +c ismooth = 1 --> weak smoothing (5 points, centred weighted) +c ismooth = 2 --> normal smoothing (3 points, evenly weighted) +c ismooth = 3 --> strong smoothing (5 points, evenly weighted) + + +c malv august 1991 +c***************************************************************************** + + implicit none + + integer n, imax, imin, i, ismooth + real*8 x(n), y(n) +c***************************************************************************** + + imin=1 + imax=n + + if (ismooth.eq.0) then + + return + + elseif (ismooth.eq.1) then ! 5 points, with central weighting + + do i=imin,imax + if(i.eq.imin)then + y(i)=x(imin) + elseif(i.eq.imax)then + y(i)=x(imax-1)+(x(imax-1)-x(imax-3))/2.d0 + elseif(i.gt.(imin+1) .and. i.lt.(imax-1) )then + y(i) = ( x(i+2)/4.d0 + x(i+1)/2.d0 + 2.d0*x(i)/3.d0 + + & x(i-1)/2.d0 + x(i-2)/4.d0 )* 6.d0/13.d0 + else + y(i)=(x(i+1)/2.d0+x(i)+x(i-1)/2.d0)/2.d0 + end if + end do + + elseif (ismooth.eq.2) then ! 3 points, evenly spaced + + do i=imin,imax + if(i.eq.imin)then + y(i)=x(imin) + elseif(i.eq.imax)then + y(i)=x(imax-1)+(x(imax-1)-x(imax-3))/2.d0 + else + y(i) = ( x(i+1)+x(i)+x(i-1) )/3.d0 + end if + end do + + elseif (ismooth.eq.3) then ! 5 points, evenly spaced + + do i=imin,imax + if(i.eq.imin)then + y(i) = x(imin) + elseif(i.eq.(imin+1) .or. i.eq.(imax-1))then + y(i) = ( x(i+1)+x(i)+x(i-1) )/3.d0 + elseif(i.eq.imax)then + y(i) = ( x(imax-1) + x(imax-1) + x(imax-2) ) / 3.d0 + else + y(i) = ( x(i+2)+x(i+1)+x(i)+x(i-1)+x(i-2) )/5.d0 + end if + end do + + else + + write (*,*) ' Error in suaviza.f Wrong ismooth value.' + stop + + endif + +c rehago el cambio, para devolver x(i) + do i=imin,imax + x(i)=y(i) + end do + + return + end + + + + +c***************************************************************************** +c LUdec.F (includes lubksb_dp and ludcmp_dp subroutines) +ccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +c +c Solution of linear equation without inverting matrix +c using LU decomposition: +c AA * xx = bb AA, bb: known +c xx: to be found +c AA and bb are not modified in this subroutine +c +c MALV , Sep 2007 +ccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + + subroutine LUdec(xx,aa,bb,m,n) + + implicit none + +! Arguments + integer,intent(in) :: m, n + real*8,intent(in) :: aa(m,m), bb(m) + real*8,intent(out) :: xx(m) + + +! Local variables + real*8 a(n,n), b(n), x(n), d + integer i, j, indx(n) + + +! Subrutinas utilizadas +! ludcmp_dp, lubksb_dp + +!!!!!!!!!!!!!!! Comienza el programa !!!!!!!!!!!!!! + + do i=1,n + b(i) = bb(i+1) + do j=1,n + a(i,j) = aa(i+1,j+1) + enddo + enddo + + ! Descomposicion de auxm1 + call ludcmp_dp ( a, n, n, indx, d) + + ! Sustituciones foward y backwards para hallar la solucion + do i=1,n + x(i) = b(i) + enddo + call lubksb_dp( a, n, n, indx, x ) + + do i=1,n + xx(i+1) = x(i) + enddo + + return + end + +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + + subroutine ludcmp_dp(a,n,np,indx,d) + +c jul 2011 malv+fgg + + implicit none + + integer,intent(in) :: n, np + real*8,intent(inout) :: a(np,np) + real*8,intent(out) :: d + integer,intent(out) :: indx(n) + + integer i, j, k, imax + real*8,parameter :: tiny=1.0d-20 + real*8 vv(n), aamax, sum, dum + + + d=1.0d0 + do 12 i=1,n + aamax=0.0d0 + do 11 j=1,n + if (abs(a(i,j)).gt.aamax) aamax=abs(a(i,j)) +11 continue + if (aamax.eq.0.0) then + write(*,*) 'ludcmp_dp: singular matrix!' + stop + endif + vv(i)=1.0d0/aamax +12 continue + do 19 j=1,n + if (j.gt.1) then + do 14 i=1,j-1 + sum=a(i,j) + if (i.gt.1)then + do 13 k=1,i-1 + sum=sum-a(i,k)*a(k,j) +13 continue + a(i,j)=sum + endif +14 continue + endif + aamax=0.0d0 + do 16 i=j,n + sum=a(i,j) + if (j.gt.1)then + do 15 k=1,j-1 + sum=sum-a(i,k)*a(k,j) +15 continue + a(i,j)=sum + endif + dum=vv(i)*abs(sum) + if (dum.ge.aamax) then + imax=i + aamax=dum + endif +16 continue + if (j.ne.imax)then + do 17 k=1,n + dum=a(imax,k) + a(imax,k)=a(j,k) + a(j,k)=dum +17 continue + d=-d + vv(imax)=vv(j) + endif + indx(j)=imax + if(j.ne.n)then + if(a(j,j).eq.0.0)a(j,j)=tiny + dum=1.0d0/a(j,j) + do 18 i=j+1,n + a(i,j)=a(i,j)*dum +18 continue + endif +19 continue + if(a(n,n).eq.0.0)a(n,n)=tiny + return + end + +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + + subroutine lubksb_dp(a,n,np,indx,b) + +c jul 2011 malv+fgg + + implicit none + + integer,intent(in) :: n,np + real*8,intent(in) :: a(np,np) + integer,intent(in) :: indx(n) + real*8,intent(out) :: b(n) + + real*8 sum + integer ii, ll, i, j + + ii=0 + do 12 i=1,n + ll=indx(i) + sum=b(ll) + b(ll)=b(i) + if (ii.ne.0)then + do 11 j=ii,i-1 + sum=sum-a(i,j)*b(j) +11 continue + else if (sum.ne.0.0) then + ii=i + endif + b(i)=sum +12 continue + do 14 i=n,1,-1 + sum=b(i) + if(i.lt.n)then + do 13 j=i+1,n + sum=sum-a(i,j)*b(j) +13 continue + endif + b(i)=sum/a(i,i) +14 continue + return + end + + + + +c***************************************************************************** +c intersp +c *********************************************************************** + subroutine intersp(yy,zz,m,y,z,n,opt) +c interpolation soubroutine. input values: y(n) at z(n). +c output values: yy(m) at zz(m). options: 1 -> lineal; 2 -> logarithmic + +c jul 2011 malv+fgg +c *********************************************************************** + + implicit none + + integer n,m,i,j,opt + real zz(m),yy(m),z(n),y(n) + real zmin,zzmin,zmax,zzmax + +! write(*,*) ' interpolating' +! call minsp(z,n,zmin) + zmin=minval(z) +! call minsp(zz,m,zzmin) + zzmin=minval(zz) +! call maxsp(z,n,zmax) + zmax=maxval(z) +! call maxsp(zz,m,zzmax) + zzmax=maxval(zz) + + if(zzmin.lt.zmin)then + write(*,*) 'from interp: new variable out of limits' + write(*,*) zzmin,'must be .ge. ',zmin + stop +! elseif(zzmax.gt.zmax)then +! write(*,*)'from interp: new variable out of limits' +! write(*,*)zzmax, 'must be .le. ',zmax +! stop + end if + + do 1,i=1,m + + do 2,j=1,n-1 + if(zz(i).ge.z(j).and.zz(i).lt.z(j+1)) goto 3 + 2 continue +c in this case (zz(m).ge.z(n)) and j leaves the loop with j=n-1+1=n + if(opt.eq.1)then + yy(i)=y(n-1)+(y(n)-y(n-1))*(zz(i)-z(n-1))/(z(n)-z(n-1)) + elseif(opt.eq.2)then + if(y(n).eq.0.0.or.y(n-1).eq.0.0)then + yy(i)=0.0 + else + yy(i)=exp(log(y(n-1))+log(y(n)/y(n-1))* + @ (zz(i)-z(n-1))/(z(n)-z(n-1))) + end if + else + write(*,*)'from interp error: opt must be 1 or 2, opt= ',opt + end if + goto 1 + 3 continue + if(opt.eq.1)then + yy(i)=y(j)+(y(j+1)-y(j))*(zz(i)-z(j))/(z(j+1)-z(j)) + elseif(opt.eq.2)then + if(y(j+1).eq.0.0.or.y(j).eq.0.0)then + yy(i)=0.0 + else + yy(i)=exp(log(y(j))+log(y(j+1)/y(j))* + @ (zz(i)-z(j))/(z(j+1)-z(j))) + end if + else + write(*,*)'from interp error: opt must be 1 or 2, opt= ',opt + end if + 1 continue + + return + end + + + +c***************************************************************************** +c interdp +c *********************************************************************** + subroutine interdp(yy,zz,m,y,z,n,opt) +c interpolation soubroutine. input values: y(n) at z(n). +c output values: yy(m) at zz(m). options: 1 -> lineal; 2 -> logarithmic +c jul 2011: malv+fgg Adapted to LMD-MGCM +c *********************************************************************** + implicit none + integer n,m,i,j,opt + real*8 zz(m),yy(m),z(n),y(n), zmin,zzmin,zmax,zzmax + +! write (*,*) ' d interpolating ' +! call mindp (z,n,zmin) + zmin=minval(z) +! call mindp (zz,m,zzmin) + zzmin=minval(zz) +! call maxdp (z,n,zmax) + zmax=maxval(z) +! call maxdp (zz,m,zzmax) + zzmax=maxval(zz) + + if(zzmin.lt.zmin)then + write (*,*) 'from d interp: new variable out of limits' + write (*,*) zzmin,'must be .ge. ',zmin + stop +! elseif(zzmax.gt.zmax)then +! write (*,*) 'from interp: new variable out of limits' +! write (*,*) zzmax, 'must be .le. ',zmax +! stop + end if + + do 1,i=1,m + + do 2,j=1,n-1 + if(zz(i).ge.z(j).and.zz(i).lt.z(j+1)) goto 3 + 2 continue +c in this case (zz(m).eq.z(n)) and j leaves the loop with j=n-1+1=n + if(opt.eq.1)then + yy(i)=y(n-1)+(y(n)-y(n-1))*(zz(i)-z(n-1))/(z(n)-z(n-1)) + elseif(opt.eq.2)then + if(y(n).eq.0.0d0.or.y(n-1).eq.0.0d0)then + yy(i)=0.0d0 + else + yy(i)=dexp(dlog(y(n-1))+dlog(y(n)/y(n-1))* + @ (zz(i)-z(n-1))/(z(n)-z(n-1))) + end if + else + write (*,*) + @ ' from d interp error: opt must be 1 or 2, opt= ',opt + end if + goto 1 + 3 continue + if(opt.eq.1)then + yy(i)=y(j)+(y(j+1)-y(j))*(zz(i)-z(j))/(z(j+1)-z(j)) +! write (*,*) ' ' +! write (*,*) ' z(j),z(j+1) =', z(j),z(j+1) +! write (*,*) ' t(j),t(j+1) =', y(j),y(j+1) +! write (*,*) ' zz, tt = ', zz(i), yy(i) + elseif(opt.eq.2)then + if(y(j+1).eq.0.0d0.or.y(j).eq.0.0d0)then + yy(i)=0.0d0 + else + yy(i)=dexp(dlog(y(j))+dlog(y(j+1)/y(j))* + @ (zz(i)-z(j))/(z(j+1)-z(j))) + end if + else + write (*,*) ' from interp error: opt must be 1 or 2, opt= ', + @ opt + end if + 1 continue + return + end + + +c***************************************************************************** +c interdp_limits.F +c *********************************************************************** + + subroutine interdp_limits ( yy,zz,m, i1,i2, y,z,n, j1,j2, opt) + +c Interpolation soubroutine. +c Returns values between indexes i1 & i2, donde 1 =< i1 =< i2 =< m +c Solo usan los indices de los inputs entre j1,j2, 1 =< j1 =< j2 =< n +c Input values: y(n) , z(n) (solo se usan los valores entre j1,j2) +c zz(m) (solo se necesita entre i1,i2) +c Output values: yy(m) (solo se calculan entre i1,i2) +c Options: opt=1 -> lineal ,, opt=2 -> logarithmic +c Difference with interdp: +c here interpolation proceeds between indexes i1,i2 only +c if i1=1 & i2=m, both subroutines are exactly the same +c thus previous calls to interdp or interdp2 could be easily replaced + +c JAN 98 MALV Version for mz1d +c jul 2011 malv+fgg Adapted to LMD-MGCM +c *********************************************************************** + + implicit none + +! Arguments + integer n,m ! I. Dimensions + integer i1, i2, j1, j2, opt ! I + real*8 zz(m),yy(m) ! O + real*8 z(n),y(n) ! I + +! Local variables + integer i,j + real*8 zmin,zzmin,zmax,zzmax + +c ******************************* + +! type *, ' d interpolating ' +! call mindp_limits (z,n,zmin, j1,j2) + zmin=minval(z(j1:j2)) +! call mindp_limits (zz,m,zzmin, i1,i2) + zzmin=minval(zz(i1:i2)) +! call maxdp_limits (z,n,zmax, j1,j2) + zmax=maxval(z(j1:j2)) +! call maxdp_limits (zz,m,zzmax, i1,i2) + zzmax=maxval(zz(i1:i2)) + + if(zzmin.lt.zmin)then + write (*,*) 'from d interp: new variable out of limits' + write (*,*) zzmin,'must be .ge. ',zmin + stop +! elseif(zzmax.gt.zmax)then +! type *,'from interp: new variable out of limits' +! type *,zzmax, 'must be .le. ',zmax +! stop + end if + + do 1,i=i1,i2 + + do 2,j=j1,j2-1 + if(zz(i).ge.z(j).and.zz(i).lt.z(j+1)) goto 3 + 2 continue +c in this case (zz(i2).eq.z(j2)) and j leaves the loop with j=j2-1+1=j2 + if(opt.eq.1)then + yy(i)=y(j2-1)+(y(j2)-y(j2-1))* + $ (zz(i)-z(j2-1))/(z(j2)-z(j2-1)) + elseif(opt.eq.2)then + if(y(j2).eq.0.0d0.or.y(j2-1).eq.0.0d0)then + yy(i)=0.0d0 + else + yy(i)=exp(log(y(j2-1))+log(y(j2)/y(j2-1))* + @ (zz(i)-z(j2-1))/(z(j2)-z(j2-1))) + end if + else + write (*,*) ' d interp : opt must be 1 or 2, opt= ',opt + end if + goto 1 + 3 continue + if(opt.eq.1)then + yy(i)=y(j)+(y(j+1)-y(j))*(zz(i)-z(j))/(z(j+1)-z(j)) +! type *, ' ' +! type *, ' z(j),z(j+1) =', z(j),z(j+1) +! type *, ' t(j),t(j+1) =', y(j),y(j+1) +! type *, ' zz, tt = ', zz(i), yy(i) + elseif(opt.eq.2)then + if(y(j+1).eq.0.0d0.or.y(j).eq.0.0d0)then + yy(i)=0.0d0 + else + yy(i)=exp(log(y(j))+log(y(j+1)/y(j))* + @ (zz(i)-z(j))/(z(j+1)-z(j))) + end if + else + write (*,*) ' interp : opt must be 1 or 2, opt= ',opt + end if + 1 continue + return + end + + + + +c***************************************************************************** +c Subroutines previously included in tcrco2_subrut.F +c*********************************************************************** +c tcrco2_subrut.f +c +c jan 98 malv version for mz1d. copied from solar10/mz4sub.f +c jul 2011 malv+fgg adapted to LMD-MGCM +c*********************************************************************** + +************************************************************************ + + subroutine dinterconnection ( v, vt ) + +* input: vib. temp. from che*.for programs, vt(nl) +* output: test vibrational temp. for other che*.for, v(nl) +! iconex_smooth=1 ==> with smoothing +! iconex_smooth=0 ==> without smoothing +! iconex_tk=40 ==> with forced lte up to 40 km +! iconex_tk=20 ==> with forced lte up to 20 km +************************************************************************ + + implicit none + include 'nlte_paramdef.h' + include 'nlte_commons.h' + +c argumentos + real*8 vt(nl), v(nl) + +c local variables + integer i + +c ************* + + do i=1,nl + v(i) = vt(i) + end do + +! lo siguiente se utilizaba en solar10, pero es mejor introducirlo en +! la driver. por ahora no lo uso todavia. +! call fluctua(v,iconex_fluctua) +! call smooth_nl(v,iconex_smooth,nl) +! call forzar_tk(v,iconex_tk) + + return + end + +c*********************************************************************** + function planckdp(tp,xnu) +c returns the black body function at wavenumber xnu and temperature t. +c*********************************************************************** + + implicit none + + include 'nlte_paramdef.h' + include 'nlte_commons.h' + +! common/datis/ pi, vlight, ee, hplanck, gamma, ab, +! @ n_avog, GG, R0, cte_sb, kboltzman, raddeg +! real*8 pi, vlight, ee, hplanck, gamma, ab, +! @ n_avog, GG, R0, cte_sb, kboltzman, raddeg + + real*8 planckdp + real*8 xnu + real tp + + planckdp = gamma*xnu**3.0 / exp( ee*xnu/dble(tp) ) + !erg cm-2.sr-1/cm-1. + + return + end + +c **************************************************************** + function bandid (ib) +c returns the 2 character code of the band +c **************************************************************** + implicit none + + integer ib + character*2 bandid + + 132 format(i2) +! encode (2,132,bandid) ib + write ( bandid, 132) ib + + if ( ib .eq. 1 ) bandid = '01' + if ( ib .eq. 2 ) bandid = '02' + if ( ib .eq. 3 ) bandid = '03' + if ( ib .eq. 4 ) bandid = '04' + if ( ib .eq. 5 ) bandid = '05' + if ( ib .eq. 6 ) bandid = '06' + if ( ib .eq. 7 ) bandid = '07' + if ( ib .eq. 8 ) bandid = '08' + if ( ib .eq. 9 ) bandid = '09' + if ( ib .eq. 0 ) bandid = '00' + +c end + return + end + + + +c***************************************************************************** +c Subroutines previously included in mat_oper.F +c***************************************************************************** +c set of subroutines for the cz*.for programs: +! subroutine unit(a,n) +! subroutine diago(a,v,n) diagonal matrix with v +! subroutine invdiag(a,b,n) inverse of diagonal matrix +! subroutine sypvvv(a,b,c,d,n) suma y prod de 3 vectores, muy comun +! subroutine sypvmv(v,w,b,u,n) suma y prod de 3 vectores, muy comun +! subroutine mulmvv(w,b,u,v,n) prod matriz vector vector +! subroutine muymvv(w,b,u,v,n) prod matriz (inv.vector) vector +! subroutine samem (a,m,n) +! subroutine mulmv(a,b,c,n) +! subroutine mulmm(a,b,c,n) +! subroutine resmm(a,b,c,n) +! subroutine mulvv(a,b,c,n) +! subroutine sumvv(a,b,c,n) +! subroutine zerom(a,n) +! subroutine zero4m(a,b,c,d,n) +! subroutine zero3m(a,b,c,n) +! subroutine zero2m(a,b,n) +! subroutine zerov(a,n) +! subroutine zero4v(a,b,c,d,n) +! subroutine zero3v(a,b,c,n) +! subroutine zero2v(a,b,n) + +! +! +! May-05 Sustituimos todos los zerojt de cristina por las subrutinas +! genericas zerov*** +! +c *********************************************************************** + subroutine unit(a,n) +c store the unit value in the diagonal of a +c *********************************************************************** + real*8 a(n,n) + integer n,i,j,k + do 1,i=2,n-1 + do 2,j=2,n-1 + if(i.eq.j) then + a(i,j) = 1.d0 + else + a(i,j)=0.0d0 + end if + 2 continue + 1 continue + do k=1,n + a(n,k) = 0.0d0 + a(1,k) = 0.0d0 + a(k,1) = 0.0d0 + a(k,n) = 0.0d0 + end do + return + end + +c *********************************************************************** + subroutine diago(a,v,n) +c store the vector v in the diagonal elements of the square matrix a +c *********************************************************************** + implicit none + + integer n,i,j,k + real*8 a(n,n),v(n) + + do 1,i=2,n-1 + do 2,j=2,n-1 + if(i.eq.j) then + a(i,j) = v(i) + else + a(i,j)=0.0d0 + end if + 2 continue + 1 continue + do k=1,n + a(n,k) = 0.0d0 + a(1,k) = 0.0d0 + a(k,1) = 0.0d0 + a(k,n) = 0.0d0 + end do + return + end + +c *********************************************************************** + subroutine samem (a,m,n) +c store the matrix m in the matrix a +c *********************************************************************** + real*8 a(n,n),m(n,n) + integer n,i,j,k + do 1,i=2,n-1 + do 2,j=2,n-1 + a(i,j) = m(i,j) + 2 continue + 1 continue + do k=1,n + a(n,k) = 0.0d0 + a(1,k) = 0.0d0 + a(k,1) = 0.0d0 + a(k,n) = 0.0d0 + end do + return + end +c *********************************************************************** + subroutine mulmv(a,b,c,n) +c do a(i)=b(i,j)*c(j). a, b, and c must be distint +c *********************************************************************** + implicit none + + integer n,i,j + real*8 a(n),b(n,n),c(n),sum + + do 1,i=2,n-1 + sum=0.0d0 + do 2,j=2,n-1 + sum=sum+ (b(i,j)) * (c(j)) + 2 continue + a(i)=sum + 1 continue + a(1) = 0.0d0 + a(n) = 0.0d0 + return + end + +c *********************************************************************** + subroutine mulmm(a,b,c,n) +c *********************************************************************** + real*8 a(n,n), b(n,n), c(n,n) + integer n,i,j,k + +! do i=2,n-1 +! do j=2,n-1 +! a(i,j)= 0.d00 +! do k=2,n-1 +! a(i,j) = a(i,j) + b(i,k) * c(k,j) +! end do +! end do +! end do + do j=2,n-1 + do i=2,n-1 + a(i,j)=0.d0 + enddo + do k=2,n-1 + do i=2,n-1 + a(i,j)=a(i,j)+b(i,k)*c(k,j) + enddo + enddo + enddo + do k=1,n + a(n,k) = 0.0d0 + a(1,k) = 0.0d0 + a(k,1) = 0.0d0 + a(k,n) = 0.0d0 + end do + + return + end + +c *********************************************************************** + subroutine resmm(a,b,c,n) +c *********************************************************************** + real*8 a(n,n), b(n,n), c(n,n) + integer n,i,j,k + + do i=2,n-1 + do j=2,n-1 + a(i,j)= b(i,j) - c(i,j) + end do + end do + do k=1,n + a(n,k) = 0.0d0 + a(1,k) = 0.0d0 + a(k,1) = 0.0d0 + a(k,n) = 0.0d0 + end do + + return + end + +c *********************************************************************** + subroutine sumvv(a,b,c,n) +c a(i)=b(i)+c(i) +c *********************************************************************** + implicit none + + integer n,i + real*8 a(n),b(n),c(n) + + do 1,i=2,n-1 + a(i)= (b(i)) + (c(i)) + 1 continue + a(1) = 0.0d0 + a(n) = 0.0d0 + return + end + +c *********************************************************************** + subroutine zerom(a,n) +c a(i,j)= 0.0 +c *********************************************************************** + + implicit none + + integer n,i,j + real*8 a(n,n) + + do 1,i=1,n + do 2,j=1,n + a(i,j) = 0.0d0 + 2 continue + 1 continue + return + end + +c *********************************************************************** + subroutine zero4m(a,b,c,d,n) +c a(i,j) = b(i,j) = c(i,j) = d(i,j) = 0.0 +c *********************************************************************** + real*8 a(n,n), b(n,n), c(n,n), d(n,n) + integer n,i,j + do 1,i=1,n + do 2,j=1,n + a(i,j) = 0.0d0 + b(i,j) = 0.0d0 + c(i,j) = 0.0d0 + d(i,j) = 0.0d0 + 2 continue + 1 continue + return + end + +c *********************************************************************** + subroutine zero3m(a,b,c,n) +c a(i,j) = b(i,j) = c(i,j) = 0.0 +c ********************************************************************** + real*8 a(n,n), b(n,n), c(n,n) + integer n,i,j + do 1,i=1,n + do 2,j=1,n + a(i,j) = 0.0d0 + b(i,j) = 0.0d0 + c(i,j) = 0.0d0 + 2 continue + 1 continue + return + end + +c *********************************************************************** + subroutine zero2m(a,b,n) +c a(i,j) = b(i,j) = 0.0 +c *********************************************************************** + real*8 a(n,n), b(n,n) + integer n,i,j + do 1,i=1,n + do 2,j=1,n + a(i,j) = 0.0d0 + b(i,j) = 0.0d0 + 2 continue + 1 continue + return + end +c *********************************************************************** + subroutine zerov(a,n) +c a(i)= 0.0 +c *********************************************************************** + real*8 a(n) + integer n,i + do 1,i=1,n + a(i) = 0.0d0 + 1 continue + return + end +c *********************************************************************** + subroutine zero4v(a,b,c,d,n) +c a(i) = b(i) = c(i) = d(i,j) = 0.0 +c *********************************************************************** + real*8 a(n), b(n), c(n), d(n) + integer n,i + do 1,i=1,n + a(i) = 0.0d0 + b(i) = 0.0d0 + c(i) = 0.0d0 + d(i) = 0.0d0 + 1 continue + return + end +c *********************************************************************** + subroutine zero3v(a,b,c,n) +c a(i) = b(i) = c(i) = 0.0 +c *********************************************************************** + real*8 a(n), b(n), c(n) + integer n,i + do 1,i=1,n + a(i) = 0.0d0 + b(i) = 0.0d0 + c(i) = 0.0d0 + 1 continue + return + end +c *********************************************************************** + subroutine zero2v(a,b,n) +c a(i) = b(i) = 0.0 +c *********************************************************************** + real*8 a(n), b(n) + integer n,i + do 1,i=1,n + a(i) = 0.0d0 + b(i) = 0.0d0 + 1 continue + return + end + + Index: trunk/LMDZ.MARS/libf/phymars/nlte_calc.F =================================================================== --- trunk/LMDZ.MARS/libf/phymars/nlte_calc.F (revision 498) +++ trunk/LMDZ.MARS/libf/phymars/nlte_calc.F (revision 498) @@ -0,0 +1,4088 @@ +c*********************************************************************** +c mzescape.f +c*********************************************************************** +c +c program for calculating atmospheric escape functions, from +c a calculation of transmittances and derivatives of these ones + + subroutine mzescape(ig,taustar,tauinf,tauii, ib,isot, iirw,iimu) + +c jul 2011 malv+fgg adapted to LMD-MGCM +c nov 99 malv adapt mztf to compute taustar (pg.23b-ma +c nov 98 malv allow for overlaping in the lorentz line +c jan 98 malv version for mz1d. based on curtis/mztf.for +c 17-jul-96 mlp&crs change the calculation of mr. +c evitar: divide por cero. anhadiendo: ff +c oct-92 malv correct s(t) dependence for all histogr bands +c june-92 malv proper lower levels for laser bands +c may-92 malv new temperature dependence for laser bands +c @ 991 malv boxing for the averaged absorber amount and t +c ? malv extension up to 200 km altitude in mars +c 13-nov-86 mlp include the temperature weighted to match +c the eqw in the strong doppler limit. +c*********************************************************************** + + implicit none + + include 'nlte_paramdef.h' + include 'nlte_commons.h' + + +c arguments + integer ig ! ADDED FOR TRACEBACK + real*8 taustar(nl) ! o + real*8 tauinf(nl) ! o + real*8 tauii(nl) ! o + integer ib ! i + integer isot ! i + integer iirw ! i + integer iimu ! i + + +c local variables and constants + integer i, in, ir, im, k,j + integer nmu + parameter (nmu = 8) +! real*8 tauinf(nl) + real*8 con(nzy), coninf + real*8 c1, c2, ccc + real*8 t1, t2 + real*8 p1, p2 + real*8 mr1, mr2 + real*8 st1, st2 + real*8 c1box(70), c2box(70) + real*8 ff ! to avoid too small numbers + real*8 tvtbs(nzy) + real*8 st, beta, ts, eqwmu + real*8 mu(nmu), amu(nmu) + real*8 zld(nl), zyd(nzy) + real*8 correc + real deltanux ! width of vib-rot band (cm-1) + character isotcode*2 + real*8 maximum + real*8 csL, psL, Desp, wsL ! for Strong Lorentz limit + +c formats + 111 format(a1) + 112 format(a2) + 101 format(i1) + 202 format(i2) + 180 format(a80) + 181 format(a80) +c*********************************************************************** + +c some needed values +! rl=sqrt(log(2.d0)) +! pi2 = 3.14159265358989d0 + beta = 1.8d0 +! imrco = 0.9865 + +c esto es para que las subroutines de mztfsub calculen we +c de la forma apropiada para mztf, no para fot + icls=icls_mztf + +c codigos para filenames +! if (isot .eq. 1) isotcode = '26' +! if (isot .eq. 2) isotcode = '28' +! if (isot .eq. 3) isotcode = '36' +! if (isot .eq. 4) isotcode = '27' +! if (isot .eq. 5) isotcode = '62' +! if(ib.eq.1.or.ib.eq.2.or.ib.eq.3.or.ib.eq.4.or.ib.eq.5 +! @ .or.ib.eq.6.or.ib.eq.7.or.ib.eq.8.or.ib.eq.9) then +!! encode(2,101,ibcode1)ib +! write ( ibcode1, 101) ib +! else +!! encode(2,202,ibcode2)ib +! write (ibcode2, 202) ib +! endif +! write (*,'( 30h calculating curtis matrix : ,2x, +! @ 8h band = ,i2,2x, 11h isotope = ,i2)') ib, isot + +c integration in angle !!!!!!!!!!!!!!!!!!!! + +c------- diffusivity approx. + if (iimu.eq.1) then +! write (*,*) ' diffusivity approx. beta = ',beta + mu(1) = 1.0d0 + amu(1)= 1.0d0 +c-------data for 8 points integration + elseif (iimu.eq.4) then + write (*,*)' 4 points for the gauss-legendre angle quadrature.' + mu(1)=(1.0d0+0.339981043584856)/2.0d0 + mu(2)=(1.0d0-0.339981043584856)/2.0d0 + mu(3)=(1.0d0+0.861136311594053)/2.0d0 + mu(4)=(1.0d0-0.861136311594053)/2.0d0 + amu(1)=0.652145154862546 + amu(2)=amu(1) + amu(3)=0.347854845137454 + amu(4)=amu(3) + beta=1.0d0 +c-------data for 8 points integration + elseif(iimu.eq.8) then + write (*,*)' 8 points for the gauss-legendre angle quadrature.' + mu(1)=(1.0d0+0.183434642495650)/2.0d0 + mu(2)=(1.0d0-0.183434642495650)/2.0d0 + mu(3)=(1.0d0+0.525532409916329)/2.0d0 + mu(4)=(1.0d0-0.525532409916329)/2.0d0 + mu(5)=(1.0d0+0.796666477413627)/2.0d0 + mu(6)=(1.0d0-0.796666477413627)/2.0d0 + mu(7)=(1.0d0+0.960289856497536)/2.0d0 + mu(8)=(1.0d0-0.960289856497536)/2.0d0 + amu(1)=0.362683783378362 + amu(2)=amu(1) + amu(3)=0.313706645877887 + amu(4)=amu(3) + amu(5)=0.222381034453374 + amu(6)=amu(5) + amu(7)=0.101228536290376 + amu(8)=amu(7) + beta=1.0d0 + end if +c!!!!!!!!!!!!!!!!!!!!!!! + +ccc +ccc determine abundances included in the absorber amount +ccc + +c first, set up the grid ready for interpolation. + do i=1,nzy + zyd(i) = dble(zy(i)) + enddo + do i=1,nl + zld(i) = dble(zl(i)) + enddo + +c vibr. temp of the bending mode : + if (isot.eq.1) call interdp ( tvtbs,zyd,nzy, v626t1,zld,nl, 1 ) + if (isot.eq.2) call interdp ( tvtbs,zyd,nzy, v628t1,zld,nl, 1 ) + if (isot.eq.3) call interdp ( tvtbs,zyd,nzy, v636t1,zld,nl, 1 ) + if (isot.eq.4) call interdp ( tvtbs,zyd,nzy, v627t1,zld,nl, 1 ) + +c 2nd: correccion a la n10(i) (cantidad de absorbente en el lower state) +c por similitud a la que se hace en cza.for + + do i=1,nzy + if (isot.eq.5) then + con(i) = dble( coy(i) * imrco ) + else + con(i) = dble( co2y(i) * imr(isot) ) + correc = 2.d0 * dexp( dble(-ee*elow(isot,2))/tvtbs(i) ) + con(i) = con(i) * ( 1.d0 - correc ) + endif +c----------------------------------------------------------------------- +c mlp & cristina. 17 july 1996 +c change the calculation of mr. it is used for calculating partial press +c alpha = alpha(self,co2)*pp +alpha(n2)*(pt-pp) +c for an isotope, if mr is obtained by co2*imr(iso)/nt we are considerin +c collisions with other co2 isotopes (including the major one, 626) +c as if they were with n2. assuming mr as co2/nt, we consider collisions +c of type 628-626 as of 626-626 instead of as 626-n2. +c mrx(i)=con(i)/ntx(i) ! old malv + +! mrx(i)= dble(co2x(i)/ntx(i)) ! mlp & crs + +c jan 98: +c esta modif de mlp implica anular el correc (deberia revisar esto) + mr(i) = dble(co2y(i)/nty(i)) ! malv, jan 98 + +c----------------------------------------------------------------------- + + end do + +! como beta y 1.d5 son comunes a todas las weighted absorber amounts, +! los simplificamos: +! coninf = beta * 1.d5 * dble( con(n) / log( con(n-1) / con(n) ) ) + coninf = dble( con(nzy) / log( con(nzy-1) / con(nzy) ) ) + +! write (*,*) ' coninf =', coninf + +ccc +ccc temp dependence of the band strength and +ccc nlte correction factor for the absorber amount +ccc + call mztf_correccion ( coninf, con, ib, isot, 0 ) + +ccc +ccc reads histogrammed spectral data (strength for lte and vmr=1) +ccc + !hfile1 = dirspec//'hi'//dn ! Ya no distinguimos entre d/n +!! hfile1 = dirspec//'hid' ! (see why in his.for) +! hfile1='hid' +!! if (ib.eq.13 .or. ib.eq.14 ) hfile1 = dirspec//'his' +! if (ib.eq.13 .or. ib.eq.14 ) hfile1 = 'his' + +! if(ib.eq.1.or.ib.eq.2.or.ib.eq.3.or.ib.eq.4.or.ib.eq.5 +! @ .or.ib.eq.6.or.ib.eq.7.or.ib.eq.8.or.ib.eq.9) then +! if (isot.eq.1) hisfile = hfile1//'26-'//ibcode1//'.dat' +! if (isot.eq.2) hisfile = hfile1//'28-'//ibcode1//'.dat' +! if (isot.eq.3) hisfile = hfile1//'36-'//ibcode1//'.dat' +! if (isot.eq.4) hisfile = hfile1//'27-'//ibcode1//'.dat' +! if (isot.eq.5) hisfile = hfile1//'62-'//ibcode1//'.dat' +! else +! if (isot.eq.1) hisfile = hfile1//'26-'//ibcode2//'.dat' +! if (isot.eq.2) hisfile = hfile1//'28-'//ibcode2//'.dat' +! if (isot.eq.3) hisfile = hfile1//'36-'//ibcode2//'.dat' +! if (isot.eq.4) hisfile = hfile1//'27-'//ibcode2//'.dat' +! if (isot.eq.5) hisfile = hfile1//'62-'//ibcode2//'.dat' +! endif + !write (*,*) ' /MZESCAPE/ hisfile: ', hisfile + +! the argument to rhist is to make this compatible with mztf_comp.f, +! which is a useful modification of mztf.f (to change strengths of bands +! call rhist (1.0) + if(ib.eq.1) then + if(isot.eq.1) then !Case 1 + mm=mm_c1 + nbox=nbox_c1 + tmin=tmin_c1 + tmax=tmax_c1 + do i=1,nbox_max + no(i)=no_c1(i) + dist(i)=dist_c1(i) + do j=1,nhist + sk1(j,i)=sk1_c1(j,i) + xls1(j,i)=xls1_c1(j,i) + xln1(j,i)=xln1_c1(j,i) + xld1(j,i)=xld1_c1(j,i) + enddo + enddo + do j=1,nhist + thist(j)=thist_c1(j) + enddo + else if(isot.eq.2) then !Case 2 + mm=mm_c2 + nbox=nbox_c2 + tmin=tmin_c2 + tmax=tmax_c2 + do i=1,nbox_max + no(i)=no_c2(i) + dist(i)=dist_c2(i) + do j=1,nhist + sk1(j,i)=sk1_c2(j,i) + xls1(j,i)=xls1_c2(j,i) + xln1(j,i)=xln1_c2(j,i) + xld1(j,i)=xld1_c2(j,i) + enddo + enddo + do j=1,nhist + thist(j)=thist_c2(j) + enddo + else if(isot.eq.3) then !Case 3 + mm=mm_c3 + nbox=nbox_c3 + tmin=tmin_c3 + tmax=tmax_c3 + do i=1,nbox_max + no(i)=no_c3(i) + dist(i)=dist_c3(i) + do j=1,nhist + sk1(j,i)=sk1_c3(j,i) + xls1(j,i)=xls1_c3(j,i) + xln1(j,i)=xln1_c3(j,i) + xld1(j,i)=xld1_c3(j,i) + enddo + enddo + do j=1,nhist + thist(j)=thist_c3(j) + enddo + else if(isot.eq.4) then !Case 4 + mm=mm_c4 + nbox=nbox_c4 + tmin=tmin_c4 + tmax=tmax_c4 + do i=1,nbox_max + no(i)=no_c4(i) + dist(i)=dist_c4(i) + do j=1,nhist + sk1(j,i)=sk1_c4(j,i) + xls1(j,i)=xls1_c4(j,i) + xln1(j,i)=xln1_c4(j,i) + xld1(j,i)=xld1_c4(j,i) + enddo + enddo + do j=1,nhist + thist(j)=thist_c4(j) + enddo + else + write(*,*)'isot must be 2,3 or 4 for ib=1!!' + write(*,*)'stop at mzescape/312' + stop + endif + else if (ib.eq.2) then + if(isot.eq.1) then !Case 5 + mm=mm_c5 + nbox=nbox_c5 + tmin=tmin_c5 + tmax=tmax_c5 + do i=1,nbox_max + no(i)=no_c5(i) + dist(i)=dist_c5(i) + do j=1,nhist + sk1(j,i)=sk1_c5(j,i) + xls1(j,i)=xls1_c5(j,i) + xln1(j,i)=xln1_c5(j,i) + xld1(j,i)=xld1_c5(j,i) + enddo + enddo + do j=1,nhist + thist(j)=thist_c5(j) + enddo + else + write(*,*)'isot must be 1 for ib=2!!' + write(*,*)'stop at mzescape/336' + stop + endif + else if (ib.eq.3) then + if(isot.eq.1) then !Case 6 + mm=mm_c6 + nbox=nbox_c6 + tmin=tmin_c6 + tmax=tmax_c6 + do i=1,nbox_max + no(i)=no_c6(i) + dist(i)=dist_c6(i) + do j=1,nhist + sk1(j,i)=sk1_c6(j,i) + xls1(j,i)=xls1_c6(j,i) + xln1(j,i)=xln1_c6(j,i) + xld1(j,i)=xld1_c6(j,i) + enddo + enddo + do j=1,nhist + thist(j)=thist_c6(j) + enddo + else + write(*,*)'isot must be 1 for ib=3!!' + write(*,*)'stop at mzescape/360' + stop + endif + else if (ib.eq.4) then + if(isot.eq.1) then !Case 7 + mm=mm_c7 + nbox=nbox_c7 + tmin=tmin_c7 + tmax=tmax_c7 + do i=1,nbox_max + no(i)=no_c7(i) + dist(i)=dist_c7(i) + do j=1,nhist + sk1(j,i)=sk1_c7(j,i) + xls1(j,i)=xls1_c7(j,i) + xln1(j,i)=xln1_c7(j,i) + xld1(j,i)=xld1_c7(j,i) + enddo + enddo + do j=1,nhist + thist(j)=thist_c7(j) + enddo + else + write(*,*)'isot must be 1 for ib=4!!' + write(*,*)'stop at mzescape/384' + stop + endif + else + write(*,*)'ib must be 1,2,3 or 4!!' + write(*,*)'stop at mzescape/389' + endif + if (isot.ne.5) deltanux = deltanu(isot,ib) + if (isot.eq.5) deltanux = deltanuco + +c****** +c****** calculation of tauinf(nl) +c****** + call initial + + ff=1.0e10 + + do i=nl,1,-1 + + if(i.eq.nl)then + + call intz (zl(i),c2,p2,mr2,t2, con) + do kr=1,nbox + ta(kr)=t2 + end do +! write (*,*) ' i, t2 =', i, t2 + call interstrength (st2,t2,ka,ta) + aa = p2 * coninf * mr2 * (st2 * ff) + bb = p2 * coninf * st2 + cc = coninf * st2 + dd = t2 * coninf * st2 + do kr=1,nbox + ccbox(kr) = coninf * ka(kr) + ddbox(kr) = t2 * ccbox(kr) +! c2box(kr) = c2 * ka(kr) * beta * dble(deltaz) * 1.d5 + c2box(kr) = c2 * ka(kr) * dble(deltaz) + end do +! c2 = c2 * st2 * beta * dble(deltaz) * 1.d5 + c2 = c2 * st2 * dble(deltaz) + + else + call intz (zl(i),c1,p1,mr1,t1, con) + do kr=1,nbox + ta(kr)=t1 + end do +! write (*,*) ' i, t1 =', i, t1 + call interstrength (st1,t1,ka,ta) + do kr=1,nbox +! c1box(kr) = c1 * ka(kr) * beta * dble(deltaz) * 1.d5 + c1box(kr) = c1 * ka(kr) * dble(deltaz) + end do +! c1 = c1 * st1 * beta * dble(deltaz) * 1.d5 + c1 = c1 * st1 * dble(deltaz) + aa = aa + ( p1*mr1*(c1*ff) + p2*mr2*(c2*ff)) / 2.d0 + bb = bb + ( p1*c1 + p2*c2 ) / 2.d0 + cc = cc + ( c1 + c2 ) / 2.d0 + ccc = ( c1 + c2 ) / 2.d0 + dd = dd + ( t1*c1 + t2*c2 ) / 2.d0 + do kr=1,nbox + ccbox(kr) = ccbox(kr) + + @ ( c1box(kr) + c2box(kr) )/2.d0 + ddbox(kr) = ddbox(kr) + + @ ( t1*c1box(kr)+t2*c2box(kr) )/2.d0 + end do + + mr2 = mr1 + c2=c1 + do kr=1,nbox + c2box(kr) = c1box(kr) + end do + t2=t1 + p2=p1 + end if + + pt = bb / cc + pp = aa / (cc*ff) + +! ta=dd/cc +! tdop = ta + ts = dd/cc + do kr=1,nbox + ta(kr) = ddbox(kr) / ccbox(kr) + end do +! write (*,*) ' i, ts =', i, ts + call interstrength(st,ts,ka,ta) +! call intershape(alsa,alna,alda,tdop) + call intershape(alsa,alna,alda,ta) + +* ua = cc/st + +c next loop calculates the eqw for an especified path ua,pp,pt,ta + + eqwmu = 0.0d0 + do im = 1,iimu + eqw=0.0d0 + do kr=1,nbox + ua(kr) = ccbox(kr) / ka(kr) * beta * 1.0d5 / mu(im) + if(ua(kr).lt.0.)write(*,*)'mzescape/480',ua(kr), + $ ccbox(kr),ka(kr),beta,mu(im),kr,im,i,nl + + call findw (ig,iirw, 0, csL,psL, Desp, wsL) + if ( i_supersat .eq. 0 ) then + eqw=eqw+no(kr)*w + else + eqw = w + (no(kr)-1) * ( asat_box*dist(kr) ) + endif + end do + eqwmu = eqwmu + eqw * mu(im)*amu(im) + end do + +! tauinf(i) = exp( - eqwmu / dble(deltanux) ) + tauinf(i) = 1.d0 - eqwmu / dble(deltanux) + if (tauinf(i).lt.0.d0) tauinf(i) = 0.0d0 + + if (i.eq.nl) then + taustar(i) = 0.0d0 + else + taustar(i) = dble(deltanux) * (tauinf(i+1)-tauinf(i)) +! ~ / ( beta * cc * 1.d5 ) + ~ / ( beta * ccc * 1.d5 ) + endif + + end do ! i continue + + +c****** +c****** calculation of tau(in,ir) for n<=r +c****** + + do 1 in=1,nl-1 + + call initial + + call intz (zl(in), c1,p1,mr1,t1, con) + do kr=1,nbox + ta(kr) = t1 + end do + call interstrength (st1,t1,ka,ta) + do kr=1,nbox + c1box(kr) = c1 * ka(kr) * dble(deltaz) + end do + c1 = c1 * st1 * dble(deltaz) + + call intz (zl(in+1), c2,p2,mr2,t2, con) + do kr=1,nbox + ta(kr) = t2 + end do + call interstrength (st2,t2,ka,ta) + do kr=1,nbox + c2box(kr) = c2 * ka(kr) * dble(deltaz) + end do + c2 = c2 * st2 * dble(deltaz) + + aa = aa + ( p1*mr1*(c1*ff) + p2*mr2*(c2*ff)) / 2.d0 + bb = bb + ( p1*c1 + p2*c2 ) / 2.d0 + cc = cc + ( c1 + c2 ) / 2.d0 + dd = dd + ( t1*c1 + t2*c2 ) / 2.d0 + do kr=1,nbox + ccbox(kr) = ccbox(kr) + (c1box(kr)+c2box(kr))/2.d0 + ddbox(kr) = ddbox(kr) + (t1*c1box(kr)+t2*c2box(kr))/2.d0 + end do + + mr1=mr2 + t1=t2 + c1=c2 + p1=p2 + do kr=1,nbox + c1box(kr) = c2box(kr) + end do + pt = bb / cc + pp = aa / (cc * ff) + ts = dd/cc + do kr=1,nbox + ta(kr) = ddbox(kr) / ccbox(kr) + end do + call interstrength(st,ts,ka,ta) + call intershape(alsa,alna,alda,ta) + + eqwmu = 0.0d0 + do im = 1,iimu + eqw=0.0d0 + do kr=1,nbox + ua(kr) = ccbox(kr) / ka(kr) * beta * 1.0d5 / mu(im) + if(ua(kr).lt.0.)write(*,*)'mzescape/566',ua(kr), + $ ccbox(kr),ka(kr),beta,mu(im),kr,im,i,nl + + call findw (ig,iirw, 0, csL,psL, Desp, wsL) + if ( i_supersat .eq. 0 ) then + eqw=eqw+no(kr)*w + else + eqw = w + (no(kr)-1) * ( asat_box*dist(kr) ) + endif + end do + eqwmu = eqwmu + eqw * mu(im)*amu(im) + end do + + tauii(in) = exp( - eqwmu / dble(deltanux) ) + !write (*,*) 'i,tauii=',in,tauii(in) + + 1 continue + tauii(nl) = 1.0d0 + + +c end + return + end + + + +c*********************************************************************** +c mzescape_normaliz.f +c*********************************************************************** +c +c program for correcting some strange values and for normalizing +c the atmospheric escape functions computed by mzescape_15um.f +c possibilities according to istyle (see mzescape_15um.f). +c + + subroutine mzescape_normaliz ( taustar, istyle ) + + +c dic 99 malv first version +c jul 2011 malv+fgg Adapted to LMD-MGCM +c*********************************************************************** + + implicit none + include 'nlte_paramdef.h' + include 'nlte_commons.h' + + +c arguments + real*8 taustar(nl) ! o + integer istyle ! i + +c local variables and constants + integer i, imaximum + real*8 maximum + +c*********************************************************************** + +! +! correcting strange values at top, eliminating local maxima, etc... +! + taustar(nl) = taustar(nl-1) + + if ( istyle .eq. 1 ) then + imaximum = nl + maximum = taustar(nl) + do i=1,nl-1 + if (taustar(i).gt.maximum) taustar(i) = taustar(nl) + enddo + elseif ( istyle .eq. 2 ) then + imaximum = nl + maximum = taustar(nl) + do i=nl-1,1,-1 + if (taustar(i).gt.maximum) then + maximum = taustar(i) + imaximum = i + endif + enddo + do i=imaximum,nl + if (taustar(i).lt.maximum) taustar(i) = maximum + enddo + endif + +! +! normalizing +! + do i=1,nl + taustar(i) = taustar(i) / maximum + enddo + + +c end + return + end + + + +c*********************************************************************** +c mzescape_fb.f +c*********************************************************************** + subroutine mzescape_fb(ig) + +c computes the escape functions of the most important 15um bands +c this calls mzescape ( taustar,tauinf,tauii, ib,isot, iirw,iimu + +c nov 99 malv based on cm15um_fb.f +c jul 2011 malv+fgg adapted to LMD-MGCM +c*********************************************************************** + + implicit none + + include 'nlte_paramdef.h' + include 'nlte_commons.h' + +c local variables + integer i, ib, ik, istyle + integer ig !ADDED FOR TRACEBACK + real*8 tau_factor + real*8 aux(nl), aux2(nl), aux3(nl) + +c*********************************************************************** + + call mzescape (ig,taustar21,tauinf210,tauii210,1,2,irw_mztf,imu) + call mzescape (ig,taustar31,tauinf310,tauii310,1,3,irw_mztf,imu) + call mzescape (ig,taustar41,tauinf410,tauii410,1,4,irw_mztf,imu) + + istyle = 2 + call mzescape_normaliz ( taustar21, istyle ) + call mzescape_normaliz ( taustar31, istyle ) + call mzescape_normaliz ( taustar41, istyle ) + + +c end + return + end + + + +c*********************************************************************** +c mzescape_fh.f +c*********************************************************************** + subroutine mzescape_fh(ig) + +c jul 2011 malv+fgg +c*********************************************************************** + + implicit none + + include 'nlte_paramdef.h' + include 'nlte_commons.h' + +c local variables + integer i, ib, ik, istyle + integer ig ! ADDED FOR TRACEBACK + real*8 tau_factor + real*8 aux(nl), aux2(nl), aux3(nl) + +c*********************************************************************** + + call zero4v( aux, taustar12,tauinf121,tauii121, nl) + do ik=1,3 + ib=ik+1 + call mzescape ( ig,aux,aux2,aux3, ib, 1,irw_mztf,imu ) + tau_factor = 1.d0 + if (ik.eq.1) tau_factor = dble(667.75/618.03) + if (ik.eq.3) tau_factor = dble(667.75/720.806) + do i=1,nl + taustar12(i) = taustar12(i) + aux(i) * tau_factor + tauinf121(i) = tauinf121(i) + aux2(i) * tau_factor + tauii121(i) = tauii121(i) + aux3(i) * tau_factor + enddo + enddo + + istyle = 2 + call mzescape_normaliz ( taustar12, istyle ) + + + +c end + return + end + + + + + +c*********************************************************************** +c mztud.f +c*********************************************************************** + + subroutine mztud ( ig,cf,cfup,cfdw,vc,taugr, ib,isot, + @ iirw,iimu,itauout,icfout,itableout ) + +c program for calculating atmospheric transmittances +c to be used in the calculation of curtis matrix coefficients +c i*out = 1 output of data +c i*out = 0 no output +c itableout = 30 output de toda la C.M. y el VC y las poblaciones de los +c estados 626(020), esta opcion nueva se añade porque +c itableout=1 saca o bien solamente de 5 en 5 capas +c o bien los elementos de C.M. desde una cierta capa +c (consultese elimin_mz1d.f que es quien lo hace); lo +c de las poblaciones (020) lo hace mztf_correcion.f + +c jul 2011 malv+fgg Adapted to LMD-MGCM +c jan 07 malv Add new vertical fine grid zy, similar to zx +c sep-oct 01 malv update for fluxes for hb and fb, adapt to Linux +c nov 98 mavl allow for overlaping in the lorentz line +c jan 98 malv version for mz1d. based on curtis/mztf.for +c 17-jul-96 mlp&crs change the calculation of mr. +c evitar: divide por cero. anhadiendo: ff +c oct-92 malv correct s(t) dependence for all histogr bands +c june-92 malv proper lower levels for laser bands +c may-92 malv new temperature dependence for laser bands +c @ 991 malv boxing for the averaged absorber amount and t +c ? malv extension up to 200 km altitude in mars +c 13-nov-86 mlp include the temperature weighted to match +c the eqw in the strong doppler limit. +c*********************************************************************** + + implicit none + + include 'nlte_paramdef.h' + include 'nlte_commons.h' + +c arguments + integer ig !ADDED FOR TRACEBACK + real*8 cf(nl,nl), cfup(nl,nl), cfdw(nl,nl) ! o + real*8 vc(nl), taugr(nl) ! o + integer ib ! i + integer isot ! i + integer iirw ! i + integer iimu ! i + integer itauout ! i + integer icfout ! i + integer itableout ! i + +c local variables and constants + integer i, in, ir, im, k,j + integer nmu + parameter (nmu = 8) + real*8 tau(nl,nl) + real*8 tauinf(nl) + real*8 con(nzy), coninf + real*8 c1, c2 + real*8 t1, t2 + real*8 p1, p2 + real*8 mr1, mr2 + real*8 st1, st2 + real*8 c1box(70), c2box(70) + real*8 ff ! to avoid too small numbers + real*8 tvtbs(nzy) + real*8 st, beta, ts, eqwmu + real*8 mu(nmu), amu(nmu) + real*8 zld(nl), zyd(nzy) + real*8 correc + real deltanux ! width of vib-rot band (cm-1) + character isotcode*2 + integer idummy + real*8 Desp,wsL + +c formats + 111 format(a1) + 112 format(a2) + 101 format(i1) + 202 format(i2) + 180 format(a80) + 181 format(a80) +c*********************************************************************** + +c some needed values +! rl=sqrt(log(2.d0)) +! pi2 = 3.14159265358989d0 + beta = 1.8d0 +! beta = 1.0d0 + idummy = 0 + Desp = 0.0d0 + wsL = 0.0d0 + +! write (*,*) ' MZTUD/ iirw = ', iirw + + +c esto es para que las subroutines de mztfsub calculen we +c de la forma apropiada para mztf, no para fot + icls=icls_mztf + +c codigos para filenames +! if (isot .eq. 1) isotcode = '26' +! if (isot .eq. 2) isotcode = '28' +! if (isot .eq. 3) isotcode = '36' +! if (isot .eq. 4) isotcode = '27' +! if (isot .eq. 5) isotcode = '62' +! if(ib.eq.1.or.ib.eq.2.or.ib.eq.3.or.ib.eq.4.or.ib.eq.5 +! @ .or.ib.eq.6.or.ib.eq.7.or.ib.eq.8.or.ib.eq.9) then +! write (ibcode1,101) ib +! else +! write (ibcode2,202) ib +! endif +! write (*,'( 30h calculating curtis matrix : ,2x, +! @ 8h band = ,i2,2x, 11h isotope = ,i2)') ib, isot + +c integration in angle !!!!!!!!!!!!!!!!!!!! +c------- diffusivity approx. + if (iimu.eq.1) then +! write (*,*) ' diffusivity approx. beta = ',beta + mu(1) = 1.0d0 + amu(1)= 1.0d0 +c-------data for 8 points integration + elseif (iimu.eq.4) then + write (*,*)' 4 points for the gauss-legendre angle quadrature.' + mu(1)=(1.0d0+0.339981043584856)/2.0d0 + mu(2)=(1.0d0-0.339981043584856)/2.0d0 + mu(3)=(1.0d0+0.861136311594053)/2.0d0 + mu(4)=(1.0d0-0.861136311594053)/2.0d0 + amu(1)=0.652145154862546 + amu(2)=amu(1) + amu(3)=0.347854845137454 + amu(4)=amu(3) + beta=1.0d0 +c-------data for 8 points integration + elseif(iimu.eq.8) then + write (*,*)' 8 points for the gauss-legendre angle quadrature.' + mu(1)=(1.0d0+0.183434642495650)/2.0d0 + mu(2)=(1.0d0-0.183434642495650)/2.0d0 + mu(3)=(1.0d0+0.525532409916329)/2.0d0 + mu(4)=(1.0d0-0.525532409916329)/2.0d0 + mu(5)=(1.0d0+0.796666477413627)/2.0d0 + mu(6)=(1.0d0-0.796666477413627)/2.0d0 + mu(7)=(1.0d0+0.960289856497536)/2.0d0 + mu(8)=(1.0d0-0.960289856497536)/2.0d0 + amu(1)=0.362683783378362 + amu(2)=amu(1) + amu(3)=0.313706645877887 + amu(4)=amu(3) + amu(5)=0.222381034453374 + amu(6)=amu(5) + amu(7)=0.101228536290376 + amu(8)=amu(7) + beta=1.0d0 + end if +c!!!!!!!!!!!!!!!!!!!!!!! + +ccc +ccc determine abundances included in the absorber amount +ccc + +c first, set up the grid ready for interpolation. + do i=1,nzy + zyd(i) = dble(zy(i)) + enddo + do i=1,nl + zld(i) = dble(zl(i)) + enddo +c vibr. temp of the bending mode : + if (isot.eq.1) call interdp ( tvtbs,zyd,nzy, v626t1,zld,nl, 1 ) + if (isot.eq.2) call interdp ( tvtbs,zyd,nzy, v628t1,zld,nl, 1 ) + if (isot.eq.3) call interdp ( tvtbs,zyd,nzy, v636t1,zld,nl, 1 ) + if (isot.eq.4) call interdp ( tvtbs,zyd,nzy, v627t1,zld,nl, 1 ) + !if (isot.eq.5) call interdp ( tvtbs,zxd,nz, vcot1,zld,nl, 1 ) + +c 2nd: correccion a la n10(i) (cantidad de absorbente en el lower state) +c por similitud a la que se hace en cza.for ; esto solo se hace para CO2 + !write (*,*) 'imr(isot) = ', isot, imr(isot) + do i=1,nzy + if (isot.eq.5) then + con(i) = dble( coy(i) * imrco ) + else + con(i) = dble( co2y(i) * imr(isot) ) + correc = 2.d0 * dexp( dble(-ee*elow(isot,2))/tvtbs(i) ) + con(i) = con(i) * ( 1.d0 - correc ) +! write (*,*) ' iz, correc, co2y(i), con(i) =', +! @ i,correc,co2y(i),con(i) + endif + + !----------------------------------------------------------------- + ! mlp & cristina. 17 july 1996 change the calculation of mr. + ! it is used for calculating partial press + ! alpha = alpha(self,co2)*pp +alpha(n2)*(pt-pp) + ! for an isotope, if mr is obtained by + ! co2*imr(iso)/nt + ! we are considerin collisions with other co2 isotopes + ! (including the major one, 626) as if they were with n2. + ! assuming mr as co2/nt, we consider collisions + ! of type 628-626 as of 626-626 instead of as 626-n2. + ! mrx(i)=con(i)/ntx(i) ! old malv + ! mrx(i)= dble(co2x(i)/ntx(i)) ! mlp & crs + + ! jan 98: + ! esta modif de mlp implica anular el correc (deberia revisar esto) + + mr(i) = dble(co2y(i)/nty(i)) ! malv, jan 98 + + !----------------------------------------------------------------- + + end do + +! como beta y 1.d5 son comunes a todas las weighted absorber amounts, +! los simplificamos: +! coninf = beta * 1.d5 * dble( con(n) / log( con(n-1) / con(n) ) ) + !write (*,*) ' con(nz), con(nz-1) =', con(nz), con(nz-1) + coninf = dble( con(nzy) / log( con(nzy-1) / con(nzy) ) ) + !write (*,*) ' coninf =', coninf + +ccc +ccc temp dependence of the band strength and +ccc nlte correction factor for the absorber amount +ccc + call mztf_correccion ( coninf, con, ib, isot, itableout ) +ccc +ccc reads histogrammed spectral data (strength for lte and vmr=1) +ccc + !hfile1 = dirspec//'hi'//dn !Ya no hacemos distincion d/n en esto +! hfile1 = dirspec//'hid' !(see why in his.for) +! hfile1='hid' +!! if (ib.eq.13 .or. ib.eq.14 ) hfile1 = dirspec//'his' +! if (ib.eq.13 .or. ib.eq.14 ) hfile1 = 'his' + +! if(ib.eq.1.or.ib.eq.2.or.ib.eq.3.or.ib.eq.4.or.ib.eq.5 +! @ .or.ib.eq.6.or.ib.eq.7.or.ib.eq.8.or.ib.eq.9) then +! if (isot.eq.1) hisfile = hfile1//'26-'//ibcode1//'.dat' +! if (isot.eq.2) hisfile = hfile1//'28-'//ibcode1//'.dat' +! if (isot.eq.3) hisfile = hfile1//'36-'//ibcode1//'.dat' +! if (isot.eq.4) hisfile = hfile1//'27-'//ibcode1//'.dat' +! if (isot.eq.5) hisfile = hfile1//'62-'//ibcode1//'.dat' +! else +! if (isot.eq.1) hisfile = hfile1//'26-'//ibcode2//'.dat' +! if (isot.eq.2) hisfile = hfile1//'28-'//ibcode2//'.dat' +! if (isot.eq.3) hisfile = hfile1//'36-'//ibcode2//'.dat' +! if (isot.eq.4) hisfile = hfile1//'27-'//ibcode2//'.dat' +! if (isot.eq.5) hisfile = hfile1//'62-'//ibcode2//'.dat' +! endif + if(ib.eq.1) then + if(isot.eq.1) then !Case 1 + mm=mm_c1 + nbox=nbox_c1 + tmin=tmin_c1 + tmax=tmax_c1 + do i=1,nbox_max + no(i)=no_c1(i) + dist(i)=dist_c1(i) + do j=1,nhist + sk1(j,i)=sk1_c1(j,i) + xls1(j,i)=xls1_c1(j,i) + xln1(j,i)=xln1_c1(j,i) + xld1(j,i)=xld1_c1(j,i) + enddo + enddo + do j=1,nhist + thist(j)=thist_c1(j) + enddo + else if(isot.eq.2) then !Case 2 + mm=mm_c2 + nbox=nbox_c2 + tmin=tmin_c2 + tmax=tmax_c2 + do i=1,nbox_max + no(i)=no_c2(i) + dist(i)=dist_c2(i) + do j=1,nhist + sk1(j,i)=sk1_c2(j,i) + xls1(j,i)=xls1_c2(j,i) + xln1(j,i)=xln1_c2(j,i) + xld1(j,i)=xld1_c2(j,i) + enddo + enddo + do j=1,nhist + thist(j)=thist_c2(j) + enddo + else if(isot.eq.3) then !Case 3 + mm=mm_c3 + nbox=nbox_c3 + tmin=tmin_c3 + tmax=tmax_c3 + do i=1,nbox_max + no(i)=no_c3(i) + dist(i)=dist_c3(i) + do j=1,nhist + sk1(j,i)=sk1_c3(j,i) + xls1(j,i)=xls1_c3(j,i) + xln1(j,i)=xln1_c3(j,i) + xld1(j,i)=xld1_c3(j,i) + enddo + enddo + do j=1,nhist + thist(j)=thist_c3(j) + enddo + else if(isot.eq.4) then !Case 4 + mm=mm_c4 + nbox=nbox_c4 + tmin=tmin_c4 + tmax=tmax_c4 + do i=1,nbox_max + no(i)=no_c4(i) + dist(i)=dist_c4(i) + do j=1,nhist + sk1(j,i)=sk1_c4(j,i) + xls1(j,i)=xls1_c4(j,i) + xln1(j,i)=xln1_c4(j,i) + xld1(j,i)=xld1_c4(j,i) + enddo + enddo + do j=1,nhist + thist(j)=thist_c4(j) + enddo + else + write(*,*)'isot must be 2,3 or 4 for ib=1!!' + write(*,*)'stop at mztud/324' + stop + endif + else if (ib.eq.2) then + if(isot.eq.1) then !Case 5 + mm=mm_c5 + nbox=nbox_c5 + tmin=tmin_c5 + tmax=tmax_c5 + do i=1,nbox_max + no(i)=no_c5(i) + dist(i)=dist_c5(i) + do j=1,nhist + sk1(j,i)=sk1_c5(j,i) + xls1(j,i)=xls1_c5(j,i) + xln1(j,i)=xln1_c5(j,i) + xld1(j,i)=xld1_c5(j,i) + enddo + enddo + do j=1,nhist + thist(j)=thist_c5(j) + enddo + else + write(*,*)'isot must be 1 for ib=2!!' + write(*,*)'stop at mztud/348' + stop + endif + else if (ib.eq.3) then + if(isot.eq.1) then !Case 6 + mm=mm_c6 + nbox=nbox_c6 + tmin=tmin_c6 + tmax=tmax_c6 + do i=1,nbox_max + no(i)=no_c6(i) + dist(i)=dist_c6(i) + do j=1,nhist + sk1(j,i)=sk1_c6(j,i) + xls1(j,i)=xls1_c6(j,i) + xln1(j,i)=xln1_c6(j,i) + xld1(j,i)=xld1_c6(j,i) + enddo + enddo + do j=1,nhist + thist(j)=thist_c6(j) + enddo + else + write(*,*)'isot must be 1 for ib=3!!' + write(*,*)'stop at mztud/372' + stop + endif + else if (ib.eq.4) then + if(isot.eq.1) then !Case 7 + mm=mm_c7 + nbox=nbox_c7 + tmin=tmin_c7 + tmax=tmax_c7 + do i=1,nbox_max + no(i)=no_c7(i) + dist(i)=dist_c7(i) + do j=1,nhist + sk1(j,i)=sk1_c7(j,i) + xls1(j,i)=xls1_c7(j,i) + xln1(j,i)=xln1_c7(j,i) + xld1(j,i)=xld1_c7(j,i) + enddo + enddo + do j=1,nhist + thist(j)=thist_c7(j) + enddo + else + write(*,*)'isot must be 1 for ib=4!!' + write(*,*)'stop at mztud/396' + stop + endif + else + write(*,*)'ib must be 1,2,3 or 4!!' + write(*,*)'stop at mztud/401' + endif + + + + +! write (*,*) 'hisfile: ', hisfile +! the argument to rhist is to make this compatible with mztf_comp.f, +! which is a useful modification of mztf.f (to change strengths of bands +! call rhist (1.0) + if (isot.ne.5) deltanux = deltanu(isot,ib) + if (isot.eq.5) deltanux = deltanuco + +c****** +c****** calculation of tauinf(nl) +c****** + call initial + ff=1.0e10 + + do i=nl,1,-1 + + if(i.eq.nl)then + + call intz (zl(i),c2,p2,mr2,t2, con) + do kr=1,nbox + ta(kr)=t2 + end do +! write (*,*) ' i, t2 =', i, t2 + call interstrength (st2,t2,ka,ta) + aa = p2 * coninf * mr2 * (st2 * ff) + bb = p2 * coninf * st2 + cc = coninf * st2 + dd = t2 * coninf * st2 + do kr=1,nbox + ccbox(kr) = coninf * ka(kr) + ddbox(kr) = t2 * ccbox(kr) +! c2box(kr) = c2 * ka(kr) * beta * dble(deltaz) * 1.d5 + c2box(kr) = c2 * ka(kr) * dble(deltaz) + end do +! c2 = c2 * st2 * beta * dble(deltaz) * 1.d5 + c2 = c2 * st2 * dble(deltaz) + + else + call intz (zl(i),c1,p1,mr1,t1, con) + do kr=1,nbox + ta(kr)=t1 + end do +! write (*,*) ' i, t1 =', i, t1 + call interstrength (st1,t1,ka,ta) + do kr=1,nbox +! c1box(kr) = c1 * ka(kr) * beta * dble(deltaz) * 1.d5 + c1box(kr) = c1 * ka(kr) * dble(deltaz) + end do +! c1 = c1 * st1 * beta * dble(deltaz) * 1.d5 + c1 = c1 * st1 * dble(deltaz) + aa = aa + ( p1*mr1*(c1*ff) + p2*mr2*(c2*ff)) / 2.d0 + bb = bb + ( p1*c1 + p2*c2 ) / 2.d0 + cc = cc + ( c1 + c2 ) / 2.d0 + dd = dd + ( t1*c1 + t2*c2 ) / 2.d0 + do kr=1,nbox + ccbox(kr) = ccbox(kr) + + @ ( c1box(kr) + c2box(kr) )/2.d0 + ddbox(kr) = ddbox(kr) + + @ ( t1*c1box(kr)+t2*c2box(kr) )/2.d0 + end do + + mr2 = mr1 + c2=c1 + do kr=1,nbox + c2box(kr) = c1box(kr) + end do + t2=t1 + p2=p1 + end if + + pt = bb / cc + pp = aa / (cc*ff) + +! ta=dd/cc +! tdop = ta + ts = dd/cc + do kr=1,nbox + ta(kr) = ddbox(kr) / ccbox(kr) + end do +! write (*,*) ' i, ts =', i, ts + call interstrength(st,ts,ka,ta) +! call intershape(alsa,alna,alda,tdop) + call intershape(alsa,alna,alda,ta) +* ua = cc/st + +c next loop calculates the eqw for an especified path uapp,pt,ta + + eqwmu = 0.0d0 + do im = 1,iimu + eqw=0.0d0 + do kr=1,nbox + ua(kr) = ccbox(kr) / ka(kr) * beta * 1.0d5 / mu(im) + if(ua(kr).lt.0.)write(*,*)'mztud/504',ua(kr),ccbox(kr), + $ ka(kr),beta,mu(im),kr,im,i,nl + call findw(ig,iirw, idummy,c1,p1,Desp,wsL) + if ( i_supersat .eq. 0 ) then + eqw=eqw+no(kr)*w + else + eqw = w + (no(kr)-1) * ( asat_box*dist(kr) ) + endif + end do + eqwmu = eqwmu + eqw * mu(im)*amu(im) + end do + + tauinf(i) = exp( - eqwmu / dble(deltanux) ) + + end do +! if ( isot.eq.1 .and. ib.eq.2 ) then +! write (*,*) ' tauinf(nl) = ', tauinf(nl) +! write (*,*) ' tauinf(1) = ', tauinf(1) +! endif + +c****** +c****** calculation of tau(in,ir) for n<=r +c****** + + do 1 in=1,nl-1 + call initial + call intz (zl(in), c1,p1,mr1,t1, con) + do kr=1,nbox + ta(kr) = t1 + end do + call interstrength (st1,t1,ka,ta) + do kr=1,nbox +! c1box(kr) = c1 * ka(kr) * beta * dble(deltaz) * 1.d5 + c1box(kr) = c1 * ka(kr) * dble(deltaz) + end do +! c1 = c1 * st1 * beta * dble(deltaz) * 1.d5 + c1 = c1 * st1 * dble(deltaz) + + do 2 ir=in,nl-1 + + if (ir.eq.in) then + tau(in,ir) = 1.d0 + goto 2 + end if + + call intz (zl(ir), c2,p2,mr2,t2, con) + do kr=1,nbox + ta(kr) = t2 + end do + call interstrength (st2,t2,ka,ta) + do kr=1,nbox +! c2box(kr) = c2 * ka(kr) * beta * dble(deltaz) * 1.d5 + c2box(kr) = c2 * ka(kr) * dble(deltaz) + end do +! c2 = c2 * st2 * beta * dble(deltaz) * 1.e5 + c2 = c2 * st2 * dble(deltaz) + +c aa = aa + ( p1*mr1*c1 + p2*mr2*c2 ) / 2.d0 + aa = aa + ( p1*mr1*(c1*ff) + p2*mr2*(c2*ff)) / 2.d0 + bb = bb + ( p1*c1 + p2*c2 ) / 2.d0 + cc = cc + ( c1 + c2 ) / 2.d0 + dd = dd + ( t1*c1 + t2*c2 ) / 2.d0 + do kr=1,nbox + ccbox(kr) = ccbox(kr) + ( c1box(kr) + c2box(kr) ) /2.d0 + ddbox(kr) = ddbox(kr) + + $ ( t1*c1box(kr) + t2*c2box(kr) ) /2.d0 + end do + + mr1=mr2 + t1=t2 + c1=c2 + p1=p2 + do kr=1,nbox + c1box(kr) = c2box(kr) + end do + + pt = bb / cc + pp = aa / (cc * ff) + +* ta=dd/cc +* tdop = ta + ts = dd/cc + do kr=1,nbox + ta(kr) = ddbox(kr) / ccbox(kr) + end do + call interstrength(st,ts,ka,ta) + call intershape(alsa,alna,alda,ta) +* ua = cc/st + +c next loop calculates the eqw for an especified path ua,pp,pt,ta + + eqwmu = 0.0d0 + do im = 1,iimu + eqw=0.0d0 + do kr=1,nbox + ua(kr) = ccbox(kr) / ka(kr) * beta * 1.0d5 / mu(im) + + call findw(ig,iirw, idummy,c1,p1,Desp,wsL) + if ( i_supersat .eq. 0 ) then + eqw=eqw+no(kr)*w + else + eqw = w + (no(kr)-1) * ( asat_box*dist(kr) ) + endif + end do + eqwmu = eqwmu + eqw * mu(im)*amu(im) + end do + + tau(in,ir) = exp( - eqwmu / dble(deltanux) ) + + 2 continue + + 1 continue +! if ( isot.eq.1 .and. ib.eq.2 ) then +! write (*,*) ' tau(1,*) , *=1,20 ' +! write (*,*) ( sngl(tau(1,k)), k=1,20 ) +! endif + + +c********** +c********** calculation of tau(in,ir) for n>r +c********** + + in=nl + + call initial + call intz (zl(in), c1,p1,mr1,t1, con) + do kr=1,nbox + ta(kr) = t1 + end do + call interstrength (st1,t1,ka,ta) + do kr=1,nbox +! c1box(kr) = c1 * ka(kr) * beta * dble(deltaz) * 1.d5 + c1box(kr) = c1 * ka(kr) * dble(deltaz) + end do +! c1 = c1 * st1 * beta * dble(deltaz) * 1.d5 + c1 = c1 * st1 * dble(deltaz) + + do 4 ir=in-1,1,-1 + + call intz (zl(ir), c2,p2,mr2,t2, con) + do kr=1,nbox + ta(kr) = t2 + end do + call interstrength (st2,t2,ka,ta) + do kr=1,nbox +! c2box(kr) = c2 * ka(kr) * beta * dble(deltaz) * 1.d5 + c2box(kr) = c2 * ka(kr) * dble(deltaz) + end do +! c2 = c2 * st2 * beta * dble(deltaz) * 1.d5 + c2 = c2 * st2 * dble(deltaz) + + aa = aa + ( p1*mr1*(c1*ff) + p2*mr2*(c2*ff)) / 2.d0 + bb = bb + ( p1*c1 + p2*c2 ) / 2.d0 + cc = cc + ( c1 + c2 ) / 2.d0 + dd = dd + ( t1*c1 + t2*c2 ) / 2.d0 + do kr=1,nbox + ccbox(kr) = ccbox(kr) + ( c1box(kr) + c2box(kr) ) /2.d0 + ddbox(kr) = ddbox(kr) + + $ ( t1*c1box(kr) + t2*c2box(kr) ) /2.d0 + end do + + mr1=mr2 + c1=c2 + t1=t2 + p1=p2 + do kr=1,nbox + c1box(kr) = c2box(kr) + end do + + pt = bb / cc + pp = aa / (cc * ff) + ts = dd / cc + do kr=1,nbox + ta(kr) = ddbox(kr) / ccbox(kr) + end do + call interstrength (st,ts,ka,ta) + call intershape (alsa,alna,alda,ta) + +* ua = cc/st + +c next loop calculates the eqw for an especified path ua,pp,pt,ta + + eqwmu = 0.0d0 + do im = 1,iimu + eqw=0.0d0 + do kr=1,nbox + ua(kr) = ccbox(kr) / ka(kr) * beta * 1.0d5 / mu(im) + if(ua(kr).lt.0.)write(*,*)'mztud/691',ua(kr),ccbox(kr), + $ ka(kr),beta,mu(im),kr,im,i,nl + + call findw(ig,iirw, idummy,c1,p1,Desp,wsL) + if ( i_supersat .eq. 0 ) then + eqw=eqw+no(kr)*w + else + eqw = w + (no(kr)-1) * ( asat_box*dist(kr) ) + endif + end do + eqwmu = eqwmu + eqw * mu(im)*amu(im) + end do + + tau(in,ir) = exp( - eqwmu / dble(deltanux) ) + + 4 continue + +c +c due to the simmetry of the transmittances +c + do in=nl-1,2,-1 + do ir=in-1,1,-1 + tau(in,ir) = tau(ir,in) + end do + end do + + +ccc +ccc writing out transmittances +ccc + if (itauout.eq.1) then + +! if(ib.eq.1.or.ib.eq.2.or.ib.eq.3.or.ib.eq.4.or.ib.eq.5 +! @ .or.ib.eq.6.or.ib.eq.7.or.ib.eq.8.or.ib.eq.9) then +! open( 1, file= +! @ dircurtis//'taul'//isotcode//dn//ibcode1//'.dat', +! @ access='sequential', form='unformatted' ) +! else +! open( 1, file= +! @ dircurtis//'taul'//isotcode//dn//ibcode2//'.dat', +! @ access='sequential', form='unformatted' ) +! endif + +! write(1) dummy +! write(1)' format: (tauinf(n),(tau(n,r),r=1,nl),n=1,nl)' +! do in=1,nl +! write (1) tauinf(in), ( tau(in,ir), ir=1,nl ) +! end do +! close(unit=1) + + elseif (itauout.eq.2) then + +! if(ib.eq.1.or.ib.eq.2.or.ib.eq.3.or.ib.eq.4.or.ib.eq.5 +! @ .or.ib.eq.6.or.ib.eq.7.or.ib.eq.8.or.ib.eq.9) then +! open( 1, file= +! @ dircurtis//'taul'//isotcode//dn//ibcode1//'.dat') +! else +! open( 1, file= +! @ dircurtis//'taul'//isotcode//dn//ibcode2//'.dat') +! endif + +! !write(1,*) dummy +! !write(1,*) 'tij for curtis matrix calculations ' +! !write(1,*)' cira mars model atmosphere ' +! !write(1,*)' beta= ',beta,'deltanu= ',deltanux +! write(1,*) nl +! write(1,*) +! @ ' format: (tauinf(in),(tau(in,ir),ir=1,nl),in=1,nl)' + +! do in=1,nl +! write (1,*) tauinf(in) +! write (1,*) (tau(in,ir), ir=1,nl) +! end do +! close(unit=1) + +! if(ib.eq.1.or.ib.eq.2.or.ib.eq.3.or.ib.eq.4.or.ib.eq.5 +! @ .or.ib.eq.6.or.ib.eq.7.or.ib.eq.8.or.ib.eq.9) then +! write (*,'(1x, 31htransmitances written out in: ,a22)') +! @ 'taul'//isotcode//dn//ibcode1 +! else +! write (*,'(1x, 31htransmitances written out in: ,a22)') +! @ 'taul'//isotcode//dn//ibcode2 +! endif + + end if + +c cleaning of transmittances +! call elimin_tau(tau,tauinf,nl,nan,itableout,nw,dummy, +! @ isotcode,dn,ibcode2) + +c construction of the curtis matrix + + call mzcud ( tauinf,tau, cf,cfup,cfdw, vc,taugr, + @ ib,isot,icfout,itableout ) + +c end + return + end + + + + + +c*********************************************************************** +c mzcud.f +c*********************************************************************** + + subroutine mzcud( tauinf,tau, c,cup,cdw,vc,taugr, + @ ib,isot,icfout,itableout ) + +c old times mlp first version of mzcf +c a.k.murphy method to avoid extrapolation in the curtis matrix +c feb-89 malv AKM method to avoid extrapolation in C.M. +c 25-sept-96 cristina dejar las matrices en doble precision +c jan 98 malv version para mz1d +c oct 01 malv update version for fluxes for hb and fb +c jul 2011 malv+fgg Adapted to LMD-MGCM +c*********************************************************************** + + implicit none + + include 'comcstfi.h' + include 'nlte_paramdef.h' + include 'nlte_commons.h' + +c arguments + real*8 c(nl,nl), cup(nl,nl), cdw(nl,nl) ! o + real*8 vc(nl), taugr(nl) ! o + real*8 tau(nl,nl) ! i + real*8 tauinf(nl) ! i + integer ib ! i + integer isot ! i + integer icfout, itableout ! i + +c external + external bandid + character*2 bandid + +c local variables + integer i, in, ir, iw, itblout + real*8 cfup(nl,nl), cfdw(nl,nl) + real*8 a(nl,nl), cf(nl,nl) + character isotcode*2, bcode*2 + +c formats + 101 format(i1) + 202 format(i2) + 180 format(a80) + 181 format(a80) +c*********************************************************************** + + if (isot.eq.1) isotcode = '26' + if (isot.eq.2) isotcode = '28' + if (isot.eq.3) isotcode = '36' + if (isot.eq.4) isotcode = '27' + if (isot.eq.5) isotcode = 'co' + bcode = bandid( ib ) + +! write (*,*) ' ' + + do in=1,nl + + do ir=1,nl + + cf(in,ir) = 0.0d0 + cfup(in,ir) = 0.0d0 + cfdw(in,ir) = 0.0d0 + c(in,ir) = 0.0d0 + cup(in,ir) = 0.0d0 + cdw(in,ir) = 0.0d0 + a(in,ir) = 0.0d0 + + end do + + vc(in) = 0.0d0 + taugr(in) = 0.0d0 + + end do + + +c the next lines are a reduced and equivalent way of calculating +c the c(in,ir) elements for n=2,nl1 and r=1,nl + + +c do in=2,nl1 +c do ir=1,nl +c if(ir.eq.1)then +c c(in,ir)=tau(in-1,1)-tau(in+1,1) +c elseif(ir.eq.nl)then +c c(in,ir)=tau(in+1,nl1)-tauinf(in+1)-tau(in-1,nl1)+tauinf(in-1) +c else +c c(in,ir)=tau(in+1,ir-1)-tau(in+1,ir)-tau(in-1,ir-1)+tau(in-1,ir) +c end if +c c(in,ir)=c(in,ir)*pi*deltanu(ib)/(2.*deltaz*1.0e5) +c end do +c end do +c go to 1000 + +c calculation of the matrix cfup(nl,nl) + + cfup(1,1) = 1.d0 - tau(1,1) + + do in=2,nl + do ir=1,in + + if (ir.eq.1) then + cfup(in,ir) = tau(in,ir) - tau(in,1) + elseif (ir.eq.in) then + cfup(in,ir) = 1.d0 - tau(in,ir-1) + else + cfup(in,ir) = tau(in,ir) - tau(in,ir-1) + end if + + end do + end do + +! contribution to upwards fluxes from bb at bottom : + do in=1,nl + taugr(in) = tau(in,1) + enddo + +c calculation of the matrix cfdw(nl,nl) + + cfdw(nl,nl) = 1.d0 - tauinf(nl) + + do in=1,nl-1 + do ir=in,nl + + if (ir.eq.in) then + cfdw(in,ir) = 1.d0 - tau(in,ir) + elseif (ir.eq.nl) then + cfdw(in,ir) = tau(in,ir-1) - tauinf(in) + else + cfdw(in,ir) = tau(in,ir-1) - tau(in,ir) + end if + + end do + end do + + +c calculation of the matrix cf(nl,nl) + + do in=1,nl + do ir=1,nl + + if (ir.eq.1) then + ! version con l_bb(tg) = l_bb(t(1))=j(1) (see also vc below) + ! cf(in,ir) = tau(in,ir) + ! version con l_bb(tg) =/= l_bb(t(1))=j(1) (see also vc below) + cf(in,ir) = tau(in,ir) - tau(in,1) + elseif (ir.eq.nl) then + cf(in,ir) = tauinf(in) - tau(in,ir-1) + else + cf(in,ir) = tau(in,ir) - tau(in,ir-1) + end if + + end do + end do + + +c definition of the a(nl,nl) matrix + + do in=2,nl-1 + do ir=1,nl + if (ir.eq.in+1) a(in,ir) = -1.d0 + if (ir.eq.in-1) a(in,ir) = +1.d0 + a(in,ir) = a(in,ir) / ( 2.d0*deltaz*1.d5 ) + end do + end do +! this is not needed anymore in the akm scheme +! a(1,1) = +3.d0 +! a(1,2) = -4.d0 +! a(1,3) = +1.d0 +! a(nl,nl) = -3.d0 +! a(nl,nl1) = +4.d0 +! a(nl,nl2) = -1.d0 + +c calculation of the final curtis matrix ("reduced" by murphy's method) + + if (isot.ne.5) then + do in=1,nl + do ir=1,nl + cf(in,ir) = cf(in,ir) * pi*deltanu(isot,ib) + cfup(in,ir) = cfup(in,ir) * pi*deltanu(isot,ib) + cfdw(in,ir) = cfdw(in,ir) * pi*deltanu(isot,ib) + end do + taugr(in) = taugr(in) * pi*deltanu(isot,ib) + end do + else + do in=1,nl + do ir=1,nl + cf(in,ir) = cf(in,ir) * pi*deltanuco + enddo + taugr(in) = taugr(in) * pi*deltanuco + enddo + endif + + do in=2,nl-1 + + do ir=1,nl + + do i=1,nl + ! only c contains the matrix a. matrixes cup,cdw dont because + ! these two will be used for flux calculations, not + ! only for flux divergencies + + c(in,ir) = c(in,ir) + a(in,i) * cf(i,ir) + ! from this matrix we will extract (see below) the + ! nl2 x nl2 "core" for the "reduced" final curtis matrix. + + end do + cup(in,ir) = cfup(in,ir) + cdw(in,ir) = cfdw(in,ir) + + end do + ! version con l_bb(tg) = l_bb(t(1))=j(1) (see cf above) + !vc(in) = c(in,1) + ! version con l_bb(tg) =/= l_bb(t(1))=j(1) (see cf above) + if (isot.ne.5) then + vc(in) = pi*deltanu(isot,ib)/( 2.d0*deltaz*1.d5 ) * + @ ( tau(in-1,1) - tau(in+1,1) ) + else + vc(in) = pi*deltanuco/( 2.d0*deltaz*1.d5 ) * + @ ( tau(in-1,1) - tau(in+1,1) ) + endif + + end do + + 5 continue + +! write (*,*) 'mztf/1/ c(2,*) =', (c(2,i), i=1,nl) + +! call elimin_dibuja(c,nl,itableout) + +c ventana del smoothing de c es nw=3 y de vc es 5 (puesto en lisa): +c subroutine elimin_mz4(c,vc,ilayer,nl,nan,iw, nw) + + iw = nan + if (isot.eq.4) iw = 5 ! eliminates values < 1.d-19 + if (itableout.eq.30) then + itblout = 0 + else + itblout = itableout + endif + call elimin_mz1d (c,vc,0,iw,itblout,nw) + +! upper boundary condition +! j'(nl) = j'(nl1) ==> j(nl) = 2j(nl1) - j(nl2) ==> + do in=2,nl-1 + c(in,nl-2) = c(in,nl-2) - c(in,nl) + c(in,nl-1) = c(in,nl-1) + 2.d0*c(in,nl) + cup(in,nl-2) = cup(in,nl-2) - cup(in,nl) + cup(in,nl-1) = cup(in,nl-1) + 2.d0*cup(in,nl) + cdw(in,nl-2) = cdw(in,nl-2) - cdw(in,nl) + cdw(in,nl-1) = cdw(in,nl-1) + 2.d0*cdw(in,nl) + end do +! j(nl) = j(nl1) ==> +! do in=2,nl1 +! c(in,nl1) = c(in,nl1) + c(in,nl) +! end do + +! 1000 continue + + + if (icfout.eq.1) then + +! if (ib.eq.1 .or. ib.eq.12 .or. ib.eq.16 .or. ib.eq.18) then +! codmatrx = codmatrx_fb +! else +! codmatrx = codmatrx_hot +! end if +! if (ib.eq.1.or.ib.eq.2.or.ib.eq.3.or.ib.eq.4.or.ib.eq.5 +! @ .or.ib.eq.6.or.ib.eq.7.or.ib.eq.8.or.ib.eq.9) then +! ibcode2 = '0'//ibcode1 +! else +! write ( ibcode2, 202) ib +! endif + +! open ( 1, access='sequential', form='unformatted', file= +! @ dircurtis//'cfl'//isotcode//dn//ibcode2//codmatrx//'.dat') +! open ( 2, access='sequential', form='unformatted', file= +! @ dircurtis//'cflup'//isotcode//dn//ibcode2//codmatrx//'.dat') +! open ( 3, access='sequential', form='unformatted', file= +! @ dircurtis//'cfldw'//isotcode//dn//ibcode2//codmatrx//'.dat') +! open ( 4, access='sequential', form='unformatted', file= +! @ dircurtis//'cflgr'//isotcode//dn//ibcode2//codmatrx//'.dat') + +! write(1) dummy +! write(1) ' format: (vc(n),(ch(n,r),r=2,nl-1),n=2,nl-1)' +! do in=2,nl-1 +! write(1) vc(in), (c(in,ir) , ir=2,nl-1 ) +!! write (*,*) in, vc(in) +! end do + +! write(2) dummy +! write(2)' format: (cfup(n,r),r=1,nl), n=1,nl)' +! do in=1,nl +! write(2) ( cup(in,ir) , ir=1,nl ) +! end do + +! write(3) dummy +! write(3)' format: (cfdw(n,r),r=1,nl), n=1,nl)' +! do in=1,nl +! write(3) (cdw(in,ir) , ir=1,nl ) +! end do + +! write(4) dummy +! write(4)' format: (taugr(n), n=1,nl)' +! do in=1,nl +! write(4) (taugr(in), ir=1,nl ) +! end do +! !write (*,*) ' Last value in file: ', taugr(nl) + +! write (*,'(1x,30hcurtis matrix written out in: ,a,a,a,a)' ) +! @ dircurtis//'cfl'//isotcode//dn//ibcode2//codmatrx//'.dat', +! @ dircurtis//'cflup'//isotcode//dn//ibcode2//codmatrx//'.dat', +! @ dircurtis//'cfldw'//isotcode//dn//ibcode2//codmatrx//'.dat', +! @ dircurtis//'cflgr'//isotcode//dn//ibcode2//codmatrx//'.dat' + +! close (1) +! close (2) +! close (3) +! close (4) + + else + + ! write (*,*) ' no curtis matrix output file ', char(10) + + end if + + if (itableout.eq.30) then ! Force output of C.M. in ascii file + +! if (ib.eq.1 .or. ib.eq.12 .or. ib.eq.16 .or. ib.eq.18) then +! codmatrx = codmatrx_fb +! else +! codmatrx = codmatrx_hot +! end if +! if (ib.eq.1.or.ib.eq.2.or.ib.eq.3.or.ib.eq.4.or.ib.eq.5 +! @ .or.ib.eq.6.or.ib.eq.7.or.ib.eq.8.or.ib.eq.9) then +! ibcode2 = '0'//ibcode1 +! else +! write ( ibcode2, 202) ib +! endif + +! open (10, file= +! & dircurtis//'table'//isotcode//dn//ibcode2//codmatrx//'.dat') +! write(10,*) nl, ' = number of layers ' +! write(10,*) ' format: (vc(n),(ch(n,r),r=2,nl-1),n=2,nl-1)' +! do in=2,nl-1 +! write(10,*) vc(in), (c(in,ir) , ir=2,nl-1 ) +! enddo +! close (10) + endif + +c end + return + end + + + + + +c*********************************************************************** +c mztvc +c*********************************************************************** + + subroutine mztvc ( ig,vc, ib,isot, + @ iirw,iimu,itauout,icfout,itableout ) + +c jul 2011 malv+fgg +c*********************************************************************** + + implicit none + + include 'comcstfi.h' + include 'nlte_paramdef.h' + include 'nlte_commons.h' + +c arguments + integer ig ! ADDED FOR TRACEBACK + real*8 cf(nl,nl), cfup(nl,nl), cfdw(nl,nl) ! o + real*8 vc(nl), taugr(nl) ! o + integer ib ! i + integer isot ! i + integer iirw ! i + integer iimu ! i + integer itauout ! i + integer icfout ! i + integer itableout ! i + +c local variables and constants + integer i, in, ir, im, k ,j + integer nmu + parameter (nmu = 8) + real*8 tau(nl,nl) + real*8 tauinf(nl) + real*8 con(nzy), coninf + real*8 c1, c2 + real*8 t1, t2 + real*8 p1, p2 + real*8 mr1, mr2 + real*8 st1, st2 + real*8 c1box(70), c2box(70) + real*8 ff ! to avoid too small numbers + real*8 tvtbs(nzy) + real*8 st, beta, ts, eqwmu + real*8 mu(nmu), amu(nmu) + real*8 zld(nl), zyd(nzy) + real*8 correc + real deltanux ! width of vib-rot band (cm-1) + character isotcode*2 + integer idummy + real*8 Desp,wsL + +c formats + 111 format(a1) + 112 format(a2) + 101 format(i1) + 202 format(i2) + 180 format(a80) + 181 format(a80) +c*********************************************************************** + +c some needed values +! rl=sqrt(log(2.d0)) +! pi2 = 3.14159265358989d0 + beta = 1.8d0 +! beta = 1.0d0 + idummy = 0 + Desp = 0.0d0 + wsL = 0.0d0 + + !write (*,*) ' MZTUD/ iirw = ', iirw + + +c esto es para que las subroutines de mztfsub calculen we +c de la forma apropiada para mztf, no para fot + icls=icls_mztf + +c codigos para filenames +! if (isot .eq. 1) isotcode = '26' +! if (isot .eq. 2) isotcode = '28' +! if (isot .eq. 3) isotcode = '36' +! if (isot .eq. 4) isotcode = '27' +! if (isot .eq. 5) isotcode = '62' +! if(ib.eq.1.or.ib.eq.2.or.ib.eq.3.or.ib.eq.4.or.ib.eq.5 +! @ .or.ib.eq.6.or.ib.eq.7.or.ib.eq.8.or.ib.eq.9) then +! write (ibcode1,101) ib +! else +! write (ibcode2,202) ib +! endif +! write (*,'( 30h calculating curtis matrix : ,2x, +! @ 8h band = ,i2,2x, 11h isotope = ,i2)') ib, isot + +c integration in angle !!!!!!!!!!!!!!!!!!!! + +c------- diffusivity approx. + if (iimu.eq.1) then +! write (*,*) ' diffusivity approx. beta = ',beta + mu(1) = 1.0d0 + amu(1)= 1.0d0 +c-------data for 8 points integration + elseif (iimu.eq.4) then + write (*,*)' 4 points for the gauss-legendre angle quadrature.' + mu(1)=(1.0d0+0.339981043584856)/2.0d0 + mu(2)=(1.0d0-0.339981043584856)/2.0d0 + mu(3)=(1.0d0+0.861136311594053)/2.0d0 + mu(4)=(1.0d0-0.861136311594053)/2.0d0 + amu(1)=0.652145154862546 + amu(2)=amu(1) + amu(3)=0.347854845137454 + amu(4)=amu(3) + beta=1.0d0 +c-------data for 8 points integration + elseif(iimu.eq.8) then + write (*,*)' 8 points for the gauss-legendre angle quadrature.' + mu(1)=(1.0d0+0.183434642495650)/2.0d0 + mu(2)=(1.0d0-0.183434642495650)/2.0d0 + mu(3)=(1.0d0+0.525532409916329)/2.0d0 + mu(4)=(1.0d0-0.525532409916329)/2.0d0 + mu(5)=(1.0d0+0.796666477413627)/2.0d0 + mu(6)=(1.0d0-0.796666477413627)/2.0d0 + mu(7)=(1.0d0+0.960289856497536)/2.0d0 + mu(8)=(1.0d0-0.960289856497536)/2.0d0 + amu(1)=0.362683783378362 + amu(2)=amu(1) + amu(3)=0.313706645877887 + amu(4)=amu(3) + amu(5)=0.222381034453374 + amu(6)=amu(5) + amu(7)=0.101228536290376 + amu(8)=amu(7) + beta=1.0d0 + end if +c!!!!!!!!!!!!!!!!!!!!!!! + +ccc +ccc determine abundances included in the absorber amount +ccc + +c first, set up the grid ready for interpolation. + do i=1,nzy + zyd(i) = dble(zy(i)) + enddo + do i=1,nl + zld(i) = dble(zl(i)) + enddo + +c vibr. temp of the bending mode : + if (isot.eq.1) call interdp ( tvtbs,zyd,nzy, v626t1,zld,nl, 1 ) + if (isot.eq.2) call interdp ( tvtbs,zyd,nzy, v628t1,zld,nl, 1 ) + if (isot.eq.3) call interdp ( tvtbs,zyd,nzy, v636t1,zld,nl, 1 ) + if (isot.eq.4) call interdp ( tvtbs,zyd,nzy, v627t1,zld,nl, 1 ) + !if (isot.eq.5) call interdp ( tvtbs,zxd,nz, vcot1,zld,nl, 1 ) + +c 2nd: correccion a la n10(i) (cantidad de absorbente en el lower state) +c por similitud a la que se hace en cza.for ; esto solo se hace para CO2 + + !write (*,*) 'imr(isot) = ', isot, imr(isot) + do i=1,nzy + if (isot.eq.5) then + con(i) = dble( coy(i) * imrco ) + else + con(i) = dble( co2y(i) * imr(isot) ) + correc = 2.d0 * dexp( dble(-ee*elow(isot,2))/tvtbs(i) ) + con(i) = con(i) * ( 1.d0 - correc ) +! write (*,*) ' iz, correc, co2y(i), con(i) =', +! @ i,correc,co2y(i),con(i) + endif + + !----------------------------------------------------------------- + ! mlp & cristina. 17 july 1996 change the calculation of mr. + ! it is used for calculating partial press + ! alpha = alpha(self,co2)*pp +alpha(n2)*(pt-pp) + ! for an isotope, if mr is obtained by + ! co2*imr(iso)/nt + ! we are considerin collisions with other co2 isotopes + ! (including the major one, 626) as if they were with n2. + ! assuming mr as co2/nt, we consider collisions + ! of type 628-626 as of 626-626 instead of as 626-n2. + ! mrx(i)=con(i)/ntx(i) ! old malv + ! mrx(i)= dble(co2x(i)/ntx(i)) ! mlp & crs + + ! jan 98: + ! esta modif de mlp implica anular el correc (deberia revisar esto) + + mr(i) = dble(co2y(i)/nty(i)) ! malv, jan 98 + + !----------------------------------------------------------------- + + end do + +! como beta y 1.d5 son comunes a todas las weighted absorber amounts, +! los simplificamos: +! coninf = beta * 1.d5 * dble( con(n) / log( con(n-1) / con(n) ) ) + !write (*,*) ' con(nz), con(nz-1) =', con(nz), con(nz-1) + coninf = dble( con(nzy) / log( con(nzy-1) / con(nzy) ) ) + !write (*,*) ' coninf =', coninf + +ccc +ccc temp dependence of the band strength and +ccc nlte correction factor for the absorber amount +ccc + call mztf_correccion ( coninf, con, ib, isot, itableout ) + +ccc +ccc reads histogrammed spectral data (strength for lte and vmr=1) +ccc + !hfile1 = dirspec//'hi'//dn !Ya no hacemos distincion d/n en esto +!! hfile1 = dirspec//'hid' !(see why in his.for) +! hfile1='hid' +!! if (ib.eq.13 .or. ib.eq.14 ) hfile1 = dirspec//'his' +! if (ib.eq.13 .or. ib.eq.14 ) hfile1 = 'his' + +! if(ib.eq.1.or.ib.eq.2.or.ib.eq.3.or.ib.eq.4.or.ib.eq.5 +! @ .or.ib.eq.6.or.ib.eq.7.or.ib.eq.8.or.ib.eq.9) then +! if (isot.eq.1) hisfile = hfile1//'26-'//ibcode1//'.dat' +! if (isot.eq.2) hisfile = hfile1//'28-'//ibcode1//'.dat' +! if (isot.eq.3) hisfile = hfile1//'36-'//ibcode1//'.dat' +! if (isot.eq.4) hisfile = hfile1//'27-'//ibcode1//'.dat' +! if (isot.eq.5) hisfile = hfile1//'62-'//ibcode1//'.dat' +! else +! if (isot.eq.1) hisfile = hfile1//'26-'//ibcode2//'.dat' +! if (isot.eq.2) hisfile = hfile1//'28-'//ibcode2//'.dat' +! if (isot.eq.3) hisfile = hfile1//'36-'//ibcode2//'.dat' +! if (isot.eq.4) hisfile = hfile1//'27-'//ibcode2//'.dat' +! if (isot.eq.5) hisfile = hfile1//'62-'//ibcode2//'.dat' +! endif +! write (*,*) 'hisfile: ', hisfile + +! the argument to rhist is to make this compatible with mztf_comp.f, +! which is a useful modification of mztf.f (to change strengths of bands +! call rhist (1.0) + if(ib.eq.1) then + if(isot.eq.1) then !Case 1 + mm=mm_c1 + nbox=nbox_c1 + tmin=tmin_c1 + tmax=tmax_c1 + do i=1,nbox_max + no(i)=no_c1(i) + dist(i)=dist_c1(i) + do j=1,nhist + sk1(j,i)=sk1_c1(j,i) + xls1(j,i)=xls1_c1(j,i) + xln1(j,i)=xln1_c1(j,i) + xld1(j,i)=xld1_c1(j,i) + enddo + enddo + do j=1,nhist + thist(j)=thist_c1(j) + enddo + else if(isot.eq.2) then !Case 2 + mm=mm_c2 + nbox=nbox_c2 + tmin=tmin_c2 + tmax=tmax_c2 + do i=1,nbox_max + no(i)=no_c2(i) + dist(i)=dist_c2(i) + do j=1,nhist + sk1(j,i)=sk1_c2(j,i) + xls1(j,i)=xls1_c2(j,i) + xln1(j,i)=xln1_c2(j,i) + xld1(j,i)=xld1_c2(j,i) + enddo + enddo + do j=1,nhist + thist(j)=thist_c2(j) + enddo + else if(isot.eq.3) then !Case 3 + mm=mm_c3 + nbox=nbox_c3 + tmin=tmin_c3 + tmax=tmax_c3 + do i=1,nbox_max + no(i)=no_c3(i) + dist(i)=dist_c3(i) + do j=1,nhist + sk1(j,i)=sk1_c3(j,i) + xls1(j,i)=xls1_c3(j,i) + xln1(j,i)=xln1_c3(j,i) + xld1(j,i)=xld1_c3(j,i) + enddo + enddo + do j=1,nhist + thist(j)=thist_c3(j) + enddo + else if(isot.eq.4) then !Case 4 + mm=mm_c4 + nbox=nbox_c4 + tmin=tmin_c4 + tmax=tmax_c4 + do i=1,nbox_max + no(i)=no_c4(i) + dist(i)=dist_c4(i) + do j=1,nhist + sk1(j,i)=sk1_c4(j,i) + xls1(j,i)=xls1_c4(j,i) + xln1(j,i)=xln1_c4(j,i) + xld1(j,i)=xld1_c4(j,i) + enddo + enddo + do j=1,nhist + thist(j)=thist_c4(j) + enddo + else + write(*,*)'isot must be 2,3 or 4 for ib=1!!' + write(*,*)'stop at mztvc/310' + stop + endif + else if (ib.eq.2) then + if(isot.eq.1) then !Case 5 + mm=mm_c5 + nbox=nbox_c5 + tmin=tmin_c5 + tmax=tmax_c5 + do i=1,nbox_max + no(i)=no_c5(i) + dist(i)=dist_c5(i) + do j=1,nhist + sk1(j,i)=sk1_c5(j,i) + xls1(j,i)=xls1_c5(j,i) + xln1(j,i)=xln1_c5(j,i) + xld1(j,i)=xld1_c5(j,i) + enddo + enddo + do j=1,nhist + thist(j)=thist_c5(j) + enddo + else + write(*,*)'isot must be 1 for ib=2!!' + write(*,*)'stop at mztvc/334' + stop + endif + else if (ib.eq.3) then + if(isot.eq.1) then !Case 6 + mm=mm_c6 + nbox=nbox_c6 + tmin=tmin_c6 + tmax=tmax_c6 + do i=1,nbox_max + no(i)=no_c6(i) + dist(i)=dist_c6(i) + do j=1,nhist + sk1(j,i)=sk1_c6(j,i) + xls1(j,i)=xls1_c6(j,i) + xln1(j,i)=xln1_c6(j,i) + xld1(j,i)=xld1_c6(j,i) + enddo + enddo + do j=1,nhist + thist(j)=thist_c6(j) + enddo + else + write(*,*)'isot must be 1 for ib=3!!' + write(*,*)'stop at mztvc/358' + stop + endif + else if (ib.eq.4) then + if(isot.eq.1) then !Case 7 + mm=mm_c7 + nbox=nbox_c7 + tmin=tmin_c7 + tmax=tmax_c7 + do i=1,nbox_max + no(i)=no_c7(i) + dist(i)=dist_c7(i) + do j=1,nhist + sk1(j,i)=sk1_c7(j,i) + xls1(j,i)=xls1_c7(j,i) + xln1(j,i)=xln1_c7(j,i) + xld1(j,i)=xld1_c7(j,i) + enddo + enddo + do j=1,nhist + thist(j)=thist_c7(j) + enddo + else + write(*,*)'isot must be 1 for ib=4!!' + write(*,*)'stop at mztvc/382' + stop + endif + else + write(*,*)'ib must be 1,2,3 or 4!!' + write(*,*)'stop at mztvc/387' + endif + + +c****** +c****** calculation of tau(1,ir) for 1<=r +c****** + call initial + + ff=1.0e10 + + in=1 + + tau(in,1) = 1.d0 + + call initial + call intz (zl(in), c1,p1,mr1,t1, con) + do kr=1,nbox + ta(kr) = t1 + end do + call interstrength (st1,t1,ka,ta) + do kr=1,nbox + c1box(kr) = c1 * ka(kr) * dble(deltaz) + end do + c1 = c1 * st1 * dble(deltaz) + + do 2 ir=2,nl + + call intz (zl(ir), c2,p2,mr2,t2, con) + do kr=1,nbox + ta(kr) = t2 + end do + call interstrength (st2,t2,ka,ta) + do kr=1,nbox + c2box(kr) = c2 * ka(kr) * dble(deltaz) + end do + c2 = c2 * st2 * dble(deltaz) + + aa = aa + ( p1*mr1*(c1*ff) + p2*mr2*(c2*ff)) / 2.d0 + bb = bb + ( p1*c1 + p2*c2 ) / 2.d0 + cc = cc + ( c1 + c2 ) / 2.d0 + dd = dd + ( t1*c1 + t2*c2 ) / 2.d0 + do kr=1,nbox + ccbox(kr) = ccbox(kr) + ( c1box(kr) + c2box(kr) ) /2.d0 + ddbox(kr) = ddbox(kr) + + $ ( t1*c1box(kr) + t2*c2box(kr) ) /2.d0 + end do + + mr1=mr2 + t1=t2 + c1=c2 + p1=p2 + do kr=1,nbox + c1box(kr) = c2box(kr) + end do + + pt = bb / cc + pp = aa / (cc * ff) + + ts = dd/cc + do kr=1,nbox + ta(kr) = ddbox(kr) / ccbox(kr) + end do + call interstrength(st,ts,ka,ta) + call intershape(alsa,alna,alda,ta) + + + eqwmu = 0.0d0 + do im = 1,iimu + eqw=0.0d0 + do kr=1,nbox + ua(kr) = ccbox(kr) / ka(kr) * beta * 1.0d5 / mu(im) + call findw(ig,iirw, idummy,c1,p1,Desp,wsL) + if ( i_supersat .eq. 0 ) then + eqw=eqw+no(kr)*w + else + eqw = w + (no(kr)-1) * ( asat_box*dist(kr) ) + endif + end do + eqwmu = eqwmu + eqw * mu(im)*amu(im) + end do + + tau(in,ir) = exp( - eqwmu / dble(deltanu(isot,ib)) ) + + 2 continue + + + +c +c due to the simmetry of the transmittances +c + do in=nl,2,-1 + tau(in,1) = tau(1,in) + end do + + vc(1) = 0.0d0 + vc(nl) = 0.0d0 + do in=2,nl-1 ! poner aqui nl-1 luego + vc(in) = pi*deltanu(isot,ib)/( 2.d0*deltaz*1.d5 ) * + @ ( tau(in-1,1) - tau(in+1,1) ) + end do + + +c end + return + end + + + + + +c*********************************************************************** +c mztvc_626fh.F +c*********************************************************************** + + subroutine mztvc_626fh(ig) + +c jul 2011 malv+fgg +c*********************************************************************** + + implicit none + +!!!!!!!!!!!!!!!!!!!!!!! +! common variables & constants + + include 'nlte_paramdef.h' + include 'nlte_commons.h' + +!!!!!!!!!!!!!!!!!!!!!!! +! arguments + + integer ig ! ADDED FOR TRACEBACK + +!!!!!!!!!!!!!!!!!!!!!!! +! local variables + + real*4 cdummy(nl,nl), csngl(nl,nl) + + real*8 cax1(nl,nl), cax2(nl,nl), cax3(nl,nl) + real*8 v1(nl), v2(nl), v3(nl), cm_factor, vc_factor + + integer itauout,icfout,itableout, interpol,ismooth, isngldble + integer i,j,ik,ist,isot,ib,itt + + !character bandcode*2 + character isotcode*2 + !character codmatrx_hot*5 + +!!!!!!!!!!!!!!!!!!!!!!! +! external functions + + external bandid + character*2 bandid + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! subroutines called: +! mz4sub, dmzout, readc_mz4, readcupdw, mztf + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! formatos + 132 format(i2) + +************************************************************************ +************************************************************************ + + isngldble = 1 ! =1 --> dble precission + + fileroot = 'cfl' + + ist = 1 + isot = 26 + write (isotcode,132) isot + + call zerov( vc121, nl ) + + do 11, ik=1,3 + + ib=ik+1 + + call mztvc (ig,v1, ib, 1, irw_mztf, imu, 0,0,0 ) + + do i=1,nl + + if(ik.eq.1)then + vc_factor = dble(667.75/618.03) + elseif(ik.eq.2)then + vc_factor = 1.d0 + elseif(ik.eq.3)then + vc_factor = dble(667.75/720.806) + end if + + vc121(i) = vc121(i) + v1(i) * vc_factor + + end do + + 11 continue + + + return + end + + + + + +c*********************************************************************** +c mztf_correccion +c*********************************************************************** + + subroutine mztf_correccion (coninf, con, ib, isot, icurt_pop) + +c including the dependence of the absort. coeff. on temp., vibr. temp., +c function, etc.., when neccessary. imr is already corrected in his.for +c we follow pg.39b-43a (l5): +c tvt1 is the vibr temp of the upper level +c tvt is the vibr temp of the transition itself +c tvtbs is the vibr temp of the bending mode (used in qv) +c for fundamental bands, they are not used at the moment. +c for the 15 fh and sh bands, only tvt0 is used at the moment. +c for the laser band, all of them are used following pg. 41a -l5- : +c we need s(z) and we can read s(tk) from the histogram (also called +c what we have to calculate now is the factor s(z)/s(tk) or following +c l5 notebook notation, s_nlte/s_lte. +c s_nlte/s_lte = xfactor = xlower * xqv * xes + +c icurt_pop = 30 -> Output of populations of the 0200,0220,1000 states +c = otro -> no output of these populations + +c oct 92 malv +c jan 98 malv version for mz1d +c jul 2011 malv+fgg adapted to LMD-MGCM +c*********************************************************************** + + implicit none + + include 'nlte_paramdef.h' + include 'nlte_commons.h' + +c arguments + integer ib, isot + integer icurt_pop ! output of Fermi states population + real*8 con(nzy), coninf + +! local variables + integer i + real*8 tvt0(nzy),tvt1(nzy),tvtbs(nzy), zld(nl),zyd(nzy) + real xalfa, xbeta, xtv1000, xtv0200, xtv0220, xfactor + real xqv, xnu_trans, xtv_trans, xes, xlower +c*********************************************************************** + + xfactor = 1.0 + + do i=1,nzy + zyd(i) = dble(zy(i)) + enddo + do i=1,nl + zld(i) = dble( zl(i) ) + end do + +! tvtbs is the bending mode of the molecule. used in xqv. + if (isot.eq.1) call interdp (tvtbs,zyd,nzy, v626t1,zld,nl, 1 ) + if (isot.eq.2) call interdp (tvtbs,zyd,nzy, v628t1,zld,nl, 1 ) + if (isot.eq.3) call interdp (tvtbs,zyd,nzy, v636t1,zld,nl, 1 ) + if (isot.eq.4) call interdp (tvtbs,zyd,nzy, v627t1,zld,nl, 1 ) + if (isot.eq.5) call interdp (tvtbs,zyd,nzy, vcot1,zld,nl, 1 ) + +! tvt0 is the lower level of the transition. used in xlower. + if (ib.eq.2 .or. ib.eq.3 .or. ib.eq.4 .or. ib.eq.15) then + if (isot.eq.1) call interdp (tvt0,zyd,nzy, v626t1,zld,nl, 1 ) + if (isot.eq.2) call interdp (tvt0,zyd,nzy, v628t1,zld,nl, 1 ) + if (isot.eq.3) call interdp (tvt0,zyd,nzy, v636t1,zld,nl, 1 ) + if (isot.eq.4) call interdp (tvt0,zyd,nzy, v627t1,zld,nl, 1 ) + elseif (ib.eq.6 .or. ib.eq.8 .or. ib.eq.10 + @ .or. ib.eq.13 .or. ib.eq.14 + @ .or. ib.eq.17 .or. ib.eq.19 .or. ib.eq.20) then + if (isot.eq.1) call interdp ( tvt0,zyd,nzy, v626t2,zld,nl, 1 ) + if (isot.eq.2) call interdp ( tvt0,zyd,nzy, v628t2,zld,nl, 1 ) + if (isot.eq.3) call interdp ( tvt0,zyd,nzy, v636t2,zld,nl, 1 ) + if (isot.eq.4) then + call interdp ( tvt0,zyd,nzy, v627t2,zld,nl, 1 ) + endif + else + do i=1,nzy + tvt0(i) = dble( ty(i) ) + end do + end if + +c tvt is the vt of the transition. used in xes. +c since xes=1.0 except for the laser bands, tvt is only needed for them +c but it is actually calculated from the tv of the upper and lower level +c of the transition. hence, only tvt1 remains to be read for the laser b +c tvt1 is the upper level of the transition. + if (ib.eq.13 .or. ib.eq.14) then + if (isot.eq.1) call interdp ( tvt1,zyd,nzy, v626t4,zld,nl, 1 ) + if (isot.eq.2) call interdp ( tvt1,zyd,nzy, v628t4,zld,nl, 1 ) + if (isot.eq.3) call interdp ( tvt1,zyd,nzy, v636t4,zld,nl, 1 ) + if (isot.eq.4) call interdp ( tvt1,zyd,nzy, v627t4,zld,nl, 1 ) + end if + +c here we weight the absorber amount by a factor which compensate the l +c value of the strength read from hitran. we use that factor in order t +c correct the product s*m when we later multiply those two variables. + +! if ( isot.eq.1 .and. icurt_pop.eq.30 ) then +! open (30, file='020populations.dat') +! write (30,*) ' z tv(020) tv0200 tv0220 tv1000 ' +! endif + + do i=1,nzy + + if (isot.eq.1) then + + !!! vt of the 3 levels in (020) (see pag. 36a-sn1 for this) + xalfa = 1.d0/2.d0* exp( dble(-ee*(nu12_1000-nu(1,2))/ty(i)) ) + xbeta = 1.d0/2.d0* exp( dble(-ee*(nu12_0200-nu(1,2))/ty(i)) ) + xtv0200 = dble( - ee * nu12_0200 ) / + @ ( log( xbeta/(1.d0+xalfa+xbeta) ) - + @ dble(ee*nu(1,2))/tvt0(i) ) + xtv0220 = dble( - ee * nu(1,2) ) / + @ ( log( 1.d0/(1.d0+xalfa+xbeta) ) - + @ dble(ee*nu(1,2))/tvt0(i) ) + xtv1000 = dble( - ee * nu12_1000 ) / + @ ( log( xalfa/(1.d0+xalfa+xbeta) ) - + @ dble(ee*nu(1,2))/tvt0(i) ) + !!! correccion 8-Nov-04 (see pag.9b-Marte4-) + xtv0200 = dble( - ee * nu12_0200 / + @ (log(4.*xbeta/(1.d0+xalfa+xbeta))-ee*nu(1,2)/tvt0(i))) + xtv0220 = dble( - ee * nu(1,2) / + @ ( log(2./(1.d0+xalfa+xbeta)) - ee*nu(1,2)/tvt0(i) ) ) + xtv1000 = dble( - ee * nu12_1000 / + @ ( log(4.*xalfa/(1.d0+xalfa+xbeta))-ee*nu(1,2)/tvt0(i))) + +! if ( icurt_pop.eq.30 ) then +! write (30,'( 1x,f7.2, 3x,f8.3, 2x,3(1x,f8.3) )') +! @ zx(i), tvt0(i), xtv0200, xtv0220, xtv1000 +! endif + + !!! xlower and xes for the band + if (ib.eq.19) then + xlower = exp( dble(ee*elow(isot,ib)) * + @ ( 1.d0/dble(ty(i))-1.d0/xtv0200 ) ) + xes = 1.0d0 + elseif (ib.eq.17) then + xlower = exp( dble(ee*elow(isot,ib)) * + @ ( 1.d0/dble(ty(i))-1.d0/xtv1000 ) ) + xes = 1.0d0 + elseif (ib.eq.20) then + xlower = exp( dble(ee*elow(isot,ib)) * + @ ( 1.d0/dble(ty(i))-1.d0/xtv0220 ) ) + xes = 1.0d0 + elseif (ib.eq.14) then + xlower = exp( dble(ee*nu12_1000) * + @ ( 1.d0/dble(ty(i))-1.d0/xtv1000 ) ) + xnu_trans = dble( nu(1,4)-nu12_1000 ) + xtv_trans = xnu_trans / dble(nu(1,4)/tvt1(i)- + @ nu12_1000/xtv1000) + xes = (1.d0-exp( dble(-ee*xnu_trans/xtv_trans) )) / + @ (1.d0-exp( dble(-ee*xnu_trans/ty(i)) )) + elseif (ib.eq.13) then + xlower = exp( dble(ee*nu12_0200) * + @ ( 1.d0/dble(ty(i))-1.d0/xtv0200 ) ) + xnu_trans = dble(nu(1,4)-nu12_0200) + xtv_trans = xnu_trans / dble(nu(1,4)/tvt1(i)- + @ nu12_0200/xtv0200) + xes = (1.d0-exp( dble(-ee*xnu_trans/xtv_trans) )) / + @ (1.d0-exp( dble(-ee*xnu_trans/ty(i)) )) + else + xlower = exp( dble(ee*elow(isot,ib)) * + @ ( 1.d0/dble(ty(i))-1.d0/tvt0(i) ) ) + xes = 1.0d0 + end if + xqv = (1.d0-exp( dble(-ee*667.3801/tvtbs(i)) )) / + @ (1.d0-exp( dble(-ee*667.3801/ty(i)) )) + xfactor = xlower * xqv**2.d0 * xes + + elseif (isot.eq.2) then + + xalfa = 1.d0/2.d0* exp( dble(-ee*(nu22_1000-nu(2,2))/ + @ ty(i)) ) + xbeta = 1.d0/2.d0* exp( dble(-ee*(nu22_0200-nu(2,2))/ + @ ty(i)) ) + xtv0200 = dble( - ee * nu22_0200 ) / + @ ( log( xbeta/(1.d0+xalfa+xbeta) ) - dble(ee*nu(2,2))/ + @ tvt0(i) ) + xtv1000 = dble( - ee * nu22_1000 ) / + @ ( log( xalfa/(1.d0+xalfa+xbeta) ) - dble(ee*nu(2,2))/ + @ tvt0(i) ) + + if (ib.eq.14) then + xlower = exp( dble(ee*nu22_1000) * + @ ( 1.d0/dble(ty(i))-1.d0/xtv1000 ) ) + xnu_trans = dble(nu(2,4)-nu22_1000) + xtv_trans = xnu_trans / dble(nu(2,4)/tvt1(i)-nu22_1000/ + @ xtv1000) + xes = (1.d0-exp( dble(-ee*xnu_trans/xtv_trans) )) / + @ (1.d0-exp( dble(-ee*xnu_trans/ty(i)) )) + elseif (ib.eq.13) then + xlower = exp( dble(ee*nu22_0200) * + @ ( 1.d0/dble(ty(i))-1.d0/xtv0200 ) ) + xnu_trans = dble( nu(2,4)-nu22_0200 ) + xtv_trans = xnu_trans / dble(nu(2,4)/tvt1(i)-nu22_0200/ + @ xtv0200) + xes = (1.d0-exp( dble(-ee*xnu_trans/xtv_trans) )) / + @ (1.d0-exp( dble(-ee*xnu_trans/ty(i)) )) + else + xlower = exp( dble(ee*elow(isot,ib)) * + @ ( 1.d0/dble(ty(i))-1.d0/tvt0(i) ) ) + xes = 1.0d0 + end if + xqv = (1.d0-exp( dble(-ee*662.3734/tvtbs(i)) )) / + @ (1.d0-exp( dble(-ee*662.3734/ty(i)) )) + xfactor = xlower * xqv**2.d0 * xes + + elseif (isot.eq.3) then + + xalfa = 1.d0/2.d0* exp( dble(-ee*(nu32_1000-nu(3,2))/ + @ ty(i)) ) + xbeta = 1.d0/2.d0* exp( dble(-ee*(nu32_0200-nu(3,2))/ + @ ty(i)) ) + xtv0200 = dble( - ee * nu32_0200 ) / + @ ( log( xbeta/(1.d0+xalfa+xbeta) ) - dble(ee*nu(3,2))/ + @ tvt0(i) ) + xtv1000 = dble( - ee * nu32_1000 ) / + @ ( log( xalfa/(1.d0+xalfa+xbeta) ) - dble(ee*nu(3,2))/ + @ tvt0(i) ) + + if (ib.eq.14) then + xlower = exp( dble(ee*nu32_1000) * + @ ( 1.d0/dble(ty(i))-1.d0/xtv1000 ) ) + xnu_trans = dble( nu(3,4)-nu32_1000 ) + xtv_trans = xnu_trans / dble(nu(3,4)/tvt1(i)-nu32_1000/ + @ xtv1000) + xes = (1.d0-exp( dble(-ee*xnu_trans/xtv_trans) )) / + @ (1.d0-exp( dble(-ee*xnu_trans/ty(i)) )) + elseif (ib.eq.13) then + xlower = exp( dble(ee*nu32_0200) * + @ ( 1.d0/dble(ty(i))-1.d0/xtv0200 ) ) + xnu_trans = dble( nu(3,4)-nu32_0200 ) + xtv_trans = xnu_trans / dble(nu(3,4)/tvt1(i)-nu32_0200/ + @ xtv0200) + xes = (1.d0-exp( dble(-ee*xnu_trans/xtv_trans) )) / + @ (1.d0-exp( dble(-ee*xnu_trans/ty(i)) )) + else + xlower = exp( dble(ee*elow(isot,ib)) * + @ ( 1.d0/dble(ty(i))-1.d0/tvt0(i) ) ) + xes = 1.0d0 + end if + xqv = (1.d0-exp( dble(-ee*648.4784/tvtbs(i)) )) / + @ (1.d0-exp( dble(-ee*648.4784/ty(i)) )) + xfactor = xlower * xqv**2.d0 * xes + + elseif (isot.eq.4) then + + xalfa = 1.d0/2.d0* exp( dble(-ee*(nu42_1000-nu(4,2))/ + @ ty(i)) ) + xbeta = 1.d0/2.d0* exp( dble(-ee*(nu42_0200-nu(4,2))/ + @ ty(i)) ) + xtv0200 = dble( - ee * nu42_0200 ) / + @ ( log( xbeta/(1.d0+xalfa+xbeta) ) - dble(ee*nu(4,2))/ + @ tvt0(i) ) + xtv1000 = dble( - ee * nu42_1000 ) / + @ ( log( xalfa/(1.d0+xalfa+xbeta) ) - dble(ee*nu(4,2))/ + @ tvt0(i) ) + + if (ib.eq.14) then + xlower = exp( dble(ee*nu42_1000) * + @ ( 1.d0/dble(ty(i))-1.d0/xtv1000 ) ) + xnu_trans = dble( nu(4,4)-nu42_1000 ) + xtv_trans = xnu_trans / dble(nu(4,4)/tvt1(i)-nu42_1000/ + @ xtv1000) + xes = (1.d0-exp( dble(-ee*xnu_trans/xtv_trans) )) / + @ (1.d0-exp( dble(-ee*xnu_trans/ty(i)) )) + elseif (ib.eq.13) then + xlower = exp( dble(ee*nu42_0200) * + $ ( 1.d0/dble(ty(i))-1.d0/xtv0200 ) ) + xnu_trans = dble( nu(4,4)-nu42_0200 ) + xtv_trans = xnu_trans / dble(nu(4,4)/tvt1(i)-nu42_0200/ + @ xtv0200) + xes = (1.d0-exp( dble(-ee*xnu_trans/xtv_trans) )) / + @ (1.d0-exp( dble(-ee*xnu_trans/ty(i)) )) + else + xlower = exp( dble(ee*elow(isot,ib)) * + @ ( 1.d0/dble(ty(i))-1.d0/tvt0(i) ) ) + xes = 1.0d0 + end if + xqv = (1.d0-exp( dble(-ee*664.7289/tvtbs(i)) )) / + @ (1.d0-exp( dble(-ee*664.7289/ty(i)) )) + xfactor = xlower * xqv**2.d0 * xes + + elseif (isot.eq.5 .and. ib.eq.1) then + + xlower = 1.d0 + xes = 1.0d0 + xqv = (1.d0-exp( dble(-ee*nuco_10/tvtbs(i)) )) / + @ (1.d0-exp( dble(-ee*nuco_10/ty(i)) )) + xfactor = xlower * xqv * xes + + end if + + con(i) = con(i) * xfactor + if (i.eq.nzy) coninf = coninf * xfactor + + end do + +! if ( isot.eq.1 .and. icurt_pop.eq.30 ) then +! close (30) +! endif + + return + end + + + + + +c*********************************************************************** +c mztf.f +c*********************************************************************** +c +c program for calculating atmospheric transmittances +c to be used in the calculation of curtis matrix coefficients + + subroutine mztf ( ig,cf,cfup,cfdw,vc,taugr, ib,isot, + @ iirw,iimu,itauout,icfout,itableout ) + +c i*out = 1 output of data +c i*out = 0 no output +c +c jul 2011 malv+fgg adapted to LMD-MGCM +c nov 98 mavl allow for overlaping in the lorentz line +c jan 98 malv version for mz1d. based on curtis/mztf.for +c 17-jul-96 mlp&crs change the calculation of mr. +c evitar: divide por cero. anhadiendo: ff +c oct-92 malv correct s(t) dependence for all histogr bands +c june-92 malv proper lower levels for laser bands +c may-92 malv new temperature dependence for laser bands +c @ 991 malv boxing for the averaged absorber amount and t +c ? malv extension up to 200 km altitude in mars +c 13-nov-86 mlp include the temperature weighted to match +c the eqw in the strong doppler limit. +c*********************************************************************** + + implicit none + + include 'nlte_paramdef.h' + include 'nlte_commons.h' + + +c arguments + integer ig !ADDED FOR TRACEBACK + real*8 cf(nl,nl), cfup(nl,nl), cfdw(nl,nl) ! o. + real*8 vc(nl), taugr(nl) ! o + integer ib ! i + integer isot ! i + integer iirw ! i + integer iimu ! i + integer itauout ! i + integer icfout ! i + integer itableout ! i + +c local variables and constants + integer i, in, ir, im, k ,j + integer nmu + parameter (nmu = 8) + real*8 tau(nl,nl) + real*8 tauinf(nl) + real*8 con(nzy), coninf + real*8 c1, c2 + real*8 t1, t2 + real*8 p1, p2 + real*8 mr1, mr2 + real*8 st1, st2 + real*8 c1box(70), c2box(70) + real*8 ff ! to avoid too small numbers + real*8 tvtbs(nzy) + real*8 st, beta, ts, eqwmu + real*8 mu(nmu), amu(nmu) + real*8 zld(nl), zyd(nzy) + real*8 correc + real deltanux ! width of vib-rot band (cm-1) +! character isotcode*2 + integer idummy + real*8 Desp,wsL + +c formats +! 111 format(a1) +! 112 format(a2) + 101 format(i1) + 202 format(i2) +! 180 format(a80) +! 181 format(a80) +c*********************************************************************** + +c some needed values +! rl=sqrt(log(2.d0)) +! pi2 = 3.14159265358989d0 + beta = 1.8d0 + idummy = 0 + Desp = 0.d0 + wsL = 0.d0 + +c esto es para que las subroutines de mztfsub calculen we +c de la forma apropiada para mztf, no para fot + icls=icls_mztf + +c codigos para filenames +! if (isot .eq. 1) isotcode = '26' +! if (isot .eq. 2) isotcode = '28' +! if (isot .eq. 3) isotcode = '36' +! if (isot .eq. 4) isotcode = '27' +! if (isot .eq. 5) isotcode = '62' +! if(ib.eq.1.or.ib.eq.2.or.ib.eq.3.or.ib.eq.4.or.ib.eq.5 +! @ .or.ib.eq.6.or.ib.eq.7.or.ib.eq.8.or.ib.eq.9) then +! write (ibcode1,101) ib +! else +! write (ibcode2,202) ib +! endif +! write (*,'( 30h calculating curtis matrix : ,2x, +! @ 8h band = ,i2,2x, 11h isotope = ,i2)') ib, isot + +c integration in angle !!!!!!!!!!!!!!!!!!!! + +c------- diffusivity approx. + if (iimu.eq.1) then +! write (*,*) ' diffusivity approx. beta = ',beta + mu(1) = 1.0d0 + amu(1)= 1.0d0 +c-------data for 8 points integration + elseif (iimu.eq.4) then + write (*,*)' 4 points for the gauss-legendre angle quadrature.' + mu(1)=(1.0d0+0.339981043584856)/2.0d0 + mu(2)=(1.0d0-0.339981043584856)/2.0d0 + mu(3)=(1.0d0+0.861136311594053)/2.0d0 + mu(4)=(1.0d0-0.861136311594053)/2.0d0 + amu(1)=0.652145154862546 + amu(2)=amu(1) + amu(3)=0.347854845137454 + amu(4)=amu(3) + beta=1.0d0 +c-------data for 8 points integration + elseif(iimu.eq.8) then + write (*,*)' 8 points for the gauss-legendre angle quadrature.' + mu(1)=(1.0d0+0.183434642495650)/2.0d0 + mu(2)=(1.0d0-0.183434642495650)/2.0d0 + mu(3)=(1.0d0+0.525532409916329)/2.0d0 + mu(4)=(1.0d0-0.525532409916329)/2.0d0 + mu(5)=(1.0d0+0.796666477413627)/2.0d0 + mu(6)=(1.0d0-0.796666477413627)/2.0d0 + mu(7)=(1.0d0+0.960289856497536)/2.0d0 + mu(8)=(1.0d0-0.960289856497536)/2.0d0 + amu(1)=0.362683783378362 + amu(2)=amu(1) + amu(3)=0.313706645877887 + amu(4)=amu(3) + amu(5)=0.222381034453374 + amu(6)=amu(5) + amu(7)=0.101228536290376 + amu(8)=amu(7) + beta=1.0d0 + end if +c!!!!!!!!!!!!!!!!!!!!!!! + +ccc +ccc determine abundances included in the absorber amount +ccc + +c first, set up the grid ready for interpolation. + do i=1,nzy + zyd(i) = dble(zy(i)) + enddo + do i=1,nl + zld(i) = dble(zl(i)) + enddo + + +c 2nd: correccion a la n10(i) (cantidad de absorbente en el lower state) +c por similitud a la que se hace en cza.for + + do i=1,nzy + if (isot.eq.5) then + con(i) = dble( coy(i) * imrco ) + else + con(i) = dble( co2y(i) * imr(isot) ) +c vibr. temp of the bending mode : + if(isot.eq.1) call interdp(tvtbs,zyd,nzy,v626t1,zld,nl,1) + if(isot.eq.2) call interdp(tvtbs,zyd,nzy,v628t1,zld,nl,1) + if(isot.eq.3) call interdp(tvtbs,zyd,nzy,v636t1,zld,nl,1) + if(isot.eq.4) call interdp(tvtbs,zyd,nzy,v627t1,zld,nl,1) + correc = 2.d0 * dexp( dble(-ee*elow(isot,2))/tvtbs(i) ) + con(i) = con(i) * ( 1.d0 - correc ) + endif +c----------------------------------------------------------------------- +c mlp & cristina. 17 july 1996 +c change the calculation of mr. it is used for calculating partial press +c alpha = alpha(self,co2)*pp +alpha(n2)*(pt-pp) +c for an isotope, if mr is obtained by co2*imr(iso)/nt we are considerin +c collisions with other co2 isotopes (including the major one, 626) +c as if they were with n2. assuming mr as co2/nt, we consider collisions +c of type 628-626 as of 626-626 instead of as 626-n2. +c mrx(i)=con(i)/ntx(i) ! old malv + +! mrx(i)= dble(co2x(i)/ntx(i)) ! mlp & crs + +c jan 98: +c esta modif de mlp implica anular el correc (deberia revisar esto) + mr(i) = dble(co2y(i)/nty(i)) ! malv, jan 98 + +c----------------------------------------------------------------------- + + end do + +! como beta y 1.d5 son comunes a todas las weighted absorber amounts, +! los simplificamos: +! coninf = beta * 1.d5 * dble( con(n) / log( con(n-1) / con(n) ) ) + coninf = dble( con(nzy) / log( con(nzy-1) / con(nzy) ) ) + +! write (*,*) ' coninf =', coninf + +ccc +ccc temp dependence of the band strength and +ccc nlte correction factor for the absorber amount +ccc + call mztf_correccion ( coninf, con, ib, isot, itableout ) + +ccc +ccc reads histogrammed spectral data (strength for lte and vmr=1) +ccc + !hfile1 = dirspec//'hi'//dn ! ya no distinguimos entre d/n +!! hfile1 = dirspec//'hid' ! (see why in his.for) +! hfile='hid' +!! if (ib.eq.13 .or. ib.eq.14 ) hfile1 = dirspec//'his' +! if (ib.eq.13 .or. ib.eq.14 ) hfile1 = 'his' +! +! if(ib.eq.1.or.ib.eq.2.or.ib.eq.3.or.ib.eq.4.or.ib.eq.5 +! @ .or.ib.eq.6.or.ib.eq.7.or.ib.eq.8.or.ib.eq.9) then +! if (isot.eq.1) hisfile = hfile1//'26-'//ibcode1//'.dat' +! if (isot.eq.2) hisfile = hfile1//'28-'//ibcode1//'.dat' +! if (isot.eq.3) hisfile = hfile1//'36-'//ibcode1//'.dat' +! if (isot.eq.4) hisfile = hfile1//'27-'//ibcode1//'.dat' +! if (isot.eq.5) hisfile = hfile1//'62-'//ibcode1//'.dat' +! else +! if (isot.eq.1) hisfile = hfile1//'26-'//ibcode2//'.dat' +! if (isot.eq.2) hisfile = hfile1//'28-'//ibcode2//'.dat' +! if (isot.eq.3) hisfile = hfile1//'36-'//ibcode2//'.dat' +! if (isot.eq.4) hisfile = hfile1//'27-'//ibcode2//'.dat' +! if (isot.eq.5) hisfile = hfile1//'62-'//ibcode2//'.dat' +! endif +! write (*,*) 'hisfile: ', hisfile + +! the argument to rhist is to make this compatible with mztf_comp.f, +! which is a useful modification of mztf.f (to change strengths of bands +! call rhist (1.0) + if(ib.eq.1) then + if(isot.eq.1) then !Case 1 + mm=mm_c1 + nbox=nbox_c1 + tmin=tmin_c1 + tmax=tmax_c1 + do i=1,nbox_max + no(i)=no_c1(i) + dist(i)=dist_c1(i) + do j=1,nhist + sk1(j,i)=sk1_c1(j,i) + xls1(j,i)=xls1_c1(j,i) + xln1(j,i)=xln1_c1(j,i) + xld1(j,i)=xld1_c1(j,i) + enddo + enddo + do j=1,nhist + thist(j)=thist_c1(j) + enddo + else if(isot.eq.2) then !Case 2 + mm=mm_c2 + nbox=nbox_c2 + tmin=tmin_c2 + tmax=tmax_c2 + do i=1,nbox_max + no(i)=no_c2(i) + dist(i)=dist_c2(i) + do j=1,nhist + sk1(j,i)=sk1_c2(j,i) + xls1(j,i)=xls1_c2(j,i) + xln1(j,i)=xln1_c2(j,i) + xld1(j,i)=xld1_c2(j,i) + enddo + enddo + do j=1,nhist + thist(j)=thist_c2(j) + enddo + else if(isot.eq.3) then !Case 3 + mm=mm_c3 + nbox=nbox_c3 + tmin=tmin_c3 + tmax=tmax_c3 + do i=1,nbox_max + no(i)=no_c3(i) + dist(i)=dist_c3(i) + do j=1,nhist + sk1(j,i)=sk1_c3(j,i) + xls1(j,i)=xls1_c3(j,i) + xln1(j,i)=xln1_c3(j,i) + xld1(j,i)=xld1_c3(j,i) + enddo + enddo + do j=1,nhist + thist(j)=thist_c3(j) + enddo + else if(isot.eq.4) then !Case 4 + mm=mm_c4 + nbox=nbox_c4 + tmin=tmin_c4 + tmax=tmax_c4 + do i=1,nbox_max + no(i)=no_c4(i) + dist(i)=dist_c4(i) + do j=1,nhist + sk1(j,i)=sk1_c4(j,i) + xls1(j,i)=xls1_c4(j,i) + xln1(j,i)=xln1_c4(j,i) + xld1(j,i)=xld1_c4(j,i) + enddo + enddo + do j=1,nhist + thist(j)=thist_c4(j) + enddo + else + write(*,*)'isot must be 2,3 or 4 for ib=1!!' + write(*,*)'stop at mztf_overlap/317' + stop + endif + else if (ib.eq.2) then + if(isot.eq.1) then !Case 5 + mm=mm_c5 + nbox=nbox_c5 + tmin=tmin_c5 + tmax=tmax_c5 + do i=1,nbox_max + no(i)=no_c5(i) + dist(i)=dist_c5(i) + do j=1,nhist + sk1(j,i)=sk1_c5(j,i) + xls1(j,i)=xls1_c5(j,i) + xln1(j,i)=xln1_c5(j,i) + xld1(j,i)=xld1_c5(j,i) + enddo + enddo + do j=1,nhist + thist(j)=thist_c5(j) + enddo + else + write(*,*)'isot must be 1 for ib=2!!' + write(*,*)'stop at mztf_overlap/341' + stop + endif + else if (ib.eq.3) then + if(isot.eq.1) then !Case 6 + mm=mm_c6 + nbox=nbox_c6 + tmin=tmin_c6 + tmax=tmax_c6 + do i=1,nbox_max + no(i)=no_c6(i) + dist(i)=dist_c6(i) + do j=1,nhist + sk1(j,i)=sk1_c6(j,i) + xls1(j,i)=xls1_c6(j,i) + xln1(j,i)=xln1_c6(j,i) + xld1(j,i)=xld1_c6(j,i) + enddo + enddo + do j=1,nhist + thist(j)=thist_c6(j) + enddo + else + write(*,*)'isot must be 1 for ib=3!!' + write(*,*)'stop at mztf_overlap/365' + stop + endif + else if (ib.eq.4) then + if(isot.eq.1) then !Case 7 + mm=mm_c7 + nbox=nbox_c7 + tmin=tmin_c7 + tmax=tmax_c7 + do i=1,nbox_max + no(i)=no_c7(i) + dist(i)=dist_c7(i) + do j=1,nhist + sk1(j,i)=sk1_c7(j,i) + xls1(j,i)=xls1_c7(j,i) + xln1(j,i)=xln1_c7(j,i) + xld1(j,i)=xld1_c7(j,i) + enddo + enddo + do j=1,nhist + thist(j)=thist_c7(j) + enddo + else + write(*,*)'isot must be 1 for ib=4!!' + write(*,*)'stop at mztf_overlap/389' + stop + endif + else + write(*,*)'ib must be 1,2,3 or 4!!' + write(*,*)'stop at mztf_overlap/394' + endif + + if (isot.ne.5) deltanux = deltanu(isot,ib) + if (isot.eq.5) deltanux = deltanuco + +c****** +c****** calculation of tauinf(nl) +c****** + call initial + + ff=1.0e10 + + do i=nl,1,-1 + + if(i.eq.nl)then + + call intz (zl(i),c2,p2,mr2,t2, con) + do kr=1,nbox + ta(kr)=t2 + end do +! write (*,*) ' i, t2 =', i, t2 + call interstrength (st2,t2,ka,ta) + aa = p2 * coninf * mr2 * (st2 * ff) + bb = p2 * coninf * st2 + cc = coninf * st2 + dd = t2 * coninf * st2 + do kr=1,nbox + ccbox(kr) = coninf * ka(kr) + ddbox(kr) = t2 * ccbox(kr) +! c2box(kr) = c2 * ka(kr) * beta * dble(deltaz) * 1.d5 + c2box(kr) = c2 * ka(kr) * dble(deltaz) + end do +! c2 = c2 * st2 * beta * dble(deltaz) * 1.d5 + c2 = c2 * st2 * dble(deltaz) + + else + call intz (zl(i),c1,p1,mr1,t1, con) + do kr=1,nbox + ta(kr)=t1 + end do +! write (*,*) ' i, t1 =', i, t1 + call interstrength (st1,t1,ka,ta) + do kr=1,nbox +! c1box(kr) = c1 * ka(kr) * beta * dble(deltaz) * 1.d5 + c1box(kr) = c1 * ka(kr) * dble(deltaz) + end do +! c1 = c1 * st1 * beta * dble(deltaz) * 1.d5 + c1 = c1 * st1 * dble(deltaz) + aa = aa + ( p1*mr1*(c1*ff) + p2*mr2*(c2*ff)) / 2.d0 + bb = bb + ( p1*c1 + p2*c2 ) / 2.d0 + cc = cc + ( c1 + c2 ) / 2.d0 + dd = dd + ( t1*c1 + t2*c2 ) / 2.d0 + do kr=1,nbox + ccbox(kr) = ccbox(kr) + ( c1box(kr) + c2box(kr) )/2.d0 + ddbox(kr) = ddbox(kr) + (t1*c1box(kr)+t2*c2box(kr))/2.d0 + end do + + mr2 = mr1 + c2=c1 + do kr=1,nbox + c2box(kr) = c1box(kr) + end do + t2=t1 + p2=p1 + end if + + pt = bb / cc + pp = aa / (cc*ff) + +! ta=dd/cc +! tdop = ta + ts = dd/cc + do kr=1,nbox + ta(kr) = ddbox(kr) / ccbox(kr) + end do +! write (*,*) ' i, ts =', i, ts + call interstrength(st,ts,ka,ta) +! call intershape(alsa,alna,alda,tdop) + call intershape(alsa,alna,alda,ta) + +* ua = cc/st + +c next loop calculates the eqw for an especified path ua,pp,pt,ta + + eqwmu = 0.0d0 + do im = 1,iimu + eqw=0.0d0 + do kr=1,nbox + ua(kr) = ccbox(kr) / ka(kr) * beta * 1.0d5 / mu(im) + if(ua(kr).lt.0.)write(*,*)'mztf_overlap/483',ua(kr), + $ ccbox(kr),ka(kr),beta,mu(im),kr,im,i,nl + + call findw(ig,iirw, idummy,c1,p1,Desp,wsL) + if ( i_supersat .eq. 0 ) then + eqw=eqw+no(kr)*w + else + eqw = w + (no(kr)-1) * ( asat_box*dist(kr) ) + endif + end do + eqwmu = eqwmu + eqw * mu(im)*amu(im) + end do + + tauinf(i) = exp( - eqwmu / dble(deltanux) ) + + end do ! i continue + +! if ( isot.eq.1 .and. ib.eq.2 ) then +! write (*,*) ' tauinf(nl) = ', tauinf(nl) +! write (*,*) ' tauinf(1) = ', tauinf(1) +! endif + +c****** +c****** calculation of tau(in,ir) for n<=r +c****** + + do 1 in=1,nl-1 + + call initial + call intz (zl(in), c1,p1,mr1,t1, con) + do kr=1,nbox + ta(kr) = t1 + end do + call interstrength (st1,t1,ka,ta) + do kr=1,nbox +! c1box(kr) = c1 * ka(kr) * beta * dble(deltaz) * 1.d5 + c1box(kr) = c1 * ka(kr) * dble(deltaz) + end do +! c1 = c1 * st1 * beta * dble(deltaz) * 1.d5 + c1 = c1 * st1 * dble(deltaz) + + do 2 ir=in,nl-1 + + if (ir.eq.in) then + tau(in,ir) = 1.d0 + goto 2 + end if + + call intz (zl(ir), c2,p2,mr2,t2, con) + do kr=1,nbox + ta(kr) = t2 + end do + call interstrength (st2,t2,ka,ta) + do kr=1,nbox +! c2box(kr) = c2 * ka(kr) * beta * dble(deltaz) * 1.d5 + c2box(kr) = c2 * ka(kr) * dble(deltaz) + end do +! c2 = c2 * st2 * beta * dble(deltaz) * 1.e5 + c2 = c2 * st2 * dble(deltaz) + +c aa = aa + ( p1*mr1*c1 + p2*mr2*c2 ) / 2.d0 + aa = aa + ( p1*mr1*(c1*ff) + p2*mr2*(c2*ff)) / 2.d0 + bb = bb + ( p1*c1 + p2*c2 ) / 2.d0 + cc = cc + ( c1 + c2 ) / 2.d0 + dd = dd + ( t1*c1 + t2*c2 ) / 2.d0 + do kr=1,nbox + ccbox(kr) = ccbox(kr) + ( c1box(kr) + c2box(kr) ) /2.d0 + ddbox(kr) = ddbox(kr) + + $ ( t1*c1box(kr) + t2*c2box(kr) ) /2.d0 + end do + + mr1=mr2 + t1=t2 + c1=c2 + p1=p2 + do kr=1,nbox + c1box(kr) = c2box(kr) + end do + + pt = bb / cc + pp = aa / (cc * ff) + +* ta=dd/cc +* tdop = ta + ts = dd/cc + do kr=1,nbox + ta(kr) = ddbox(kr) / ccbox(kr) + end do + call interstrength(st,ts,ka,ta) + call intershape(alsa,alna,alda,ta) +* ua = cc/st + +c next loop calculates the eqw for an especified path ua,pp,pt,ta + + eqwmu = 0.0d0 + do im = 1,iimu + eqw=0.0d0 + do kr=1,nbox + ua(kr) = ccbox(kr) / ka(kr) * beta * 1.0d5 / mu(im) + if(ua(kr).lt.0.)write(*,*)'mztf_overlap/581',ua(kr), + $ ccbox(kr),ka(kr),beta,mu(im),kr,im,i,nl + + call findw(ig,iirw, idummy,c1,p1,Desp,wsL) + if ( i_supersat .eq. 0 ) then + eqw=eqw+no(kr)*w + else + eqw = w + (no(kr)-1) * ( asat_box*dist(kr) ) + endif + end do + eqwmu = eqwmu + eqw * mu(im)*amu(im) + end do + + tau(in,ir) = exp( - eqwmu / dble(deltanux) ) + + 2 continue + + 1 continue + +! if ( isot.eq.1 .and. ib.eq.2 ) then +! write (*,*) ' tau(1,*) , *=1,20 ' +! write (*,*) ( sngl(tau(1,k)), k=1,20 ) +! endif + + +c********** +c********** calculation of tau(in,ir) for n>r +c********** + + in=nl + + call initial + call intz (zl(in), c1,p1,mr1,t1, con) + do kr=1,nbox + ta(kr) = t1 + end do + call interstrength (st1,t1,ka,ta) + do kr=1,nbox +! c1box(kr) = c1 * ka(kr) * beta * dble(deltaz) * 1.d5 + c1box(kr) = c1 * ka(kr) * dble(deltaz) + end do +! c1 = c1 * st1 * beta * dble(deltaz) * 1.d5 + c1 = c1 * st1 * dble(deltaz) + + do 4 ir=in-1,1,-1 + + call intz (zl(ir), c2,p2,mr2,t2, con) + do kr=1,nbox + ta(kr) = t2 + end do + call interstrength (st2,t2,ka,ta) + do kr=1,nbox +! c2box(kr) = c2 * ka(kr) * beta * dble(deltaz) * 1.d5 + c2box(kr) = c2 * ka(kr) * dble(deltaz) + end do +! c2 = c2 * st2 * beta * dble(deltaz) * 1.d5 + c2 = c2 * st2 * dble(deltaz) + + aa = aa + ( p1*mr1*(c1*ff) + p2*mr2*(c2*ff)) / 2.d0 + bb = bb + ( p1*c1 + p2*c2 ) / 2.d0 + cc = cc + ( c1 + c2 ) / 2.d0 + dd = dd + ( t1*c1 + t2*c2 ) / 2.d0 + do kr=1,nbox + ccbox(kr) = ccbox(kr) + ( c1box(kr) + c2box(kr) ) /2.d0 + ddbox(kr) = ddbox(kr) + ( t1*c1box(kr) + t2*c2box(kr) )/2.d0 + end do + + mr1=mr2 + c1=c2 + t1=t2 + p1=p2 + do kr=1,nbox + c1box(kr) = c2box(kr) + end do + + pt = bb / cc + pp = aa / (cc * ff) + ts = dd / cc + do kr=1,nbox + ta(kr) = ddbox(kr) / ccbox(kr) + end do + call interstrength (st,ts,ka,ta) + call intershape (alsa,alna,alda,ta) + +* ua = cc/st + +c next loop calculates the eqw for an especified path ua,pp,pt,ta + + eqwmu = 0.0d0 + do im = 1,iimu + eqw=0.0d0 + do kr=1,nbox + ua(kr) = ccbox(kr) / ka(kr) * beta * 1.0d5 / mu(im) + if(ua(kr).lt.0.)write(*,*)'mztf_overlap/674',ua(kr), + $ ccbox(kr),ka(kr),beta,mu(im),kr,im,i,nl + + call findw(ig,iirw, idummy,c1,p1,Desp,wsL) + if ( i_supersat .eq. 0 ) then + eqw=eqw+no(kr)*w + else + eqw = w + (no(kr)-1) * ( asat_box*dist(kr) ) + endif + end do + eqwmu = eqwmu + eqw * mu(im)*amu(im) + end do + + tau(in,ir) = exp( - eqwmu / dble(deltanux) ) + + 4 continue + +c +c due to the simmetry of the transmittances +c + do in=nl-1,2,-1 + do ir=in-1,1,-1 + tau(in,ir) = tau(ir,in) + end do + end do + + +ccc +ccc writing out transmittances +ccc + if (itauout.eq.1) then + +! if(ib.eq.1.or.ib.eq.2.or.ib.eq.3.or.ib.eq.4.or.ib.eq.5 +! @ .or.ib.eq.6.or.ib.eq.7.or.ib.eq.8.or.ib.eq.9) then +! open( 1, file= +! @ dircurtis//'taul'//isotcode//dn//ibcode1//'.dat', +! @ access='sequential', form='unformatted' ) +! else +! open( 1, file= +! @ dircurtis//'taul'//isotcode//dn//ibcode2//'.dat', +! @ access='sequential', form='unformatted' ) +! endif + +! write(1) dummy +! write(1)' format: (tauinf(n),(tau(n,r),r=1,nl),n=1,nl)' +! do in=1,nl +! write (1) tauinf(in), ( tau(in,ir), ir=1,nl ) +! end do +! close(unit=1) + + elseif (itauout.eq.2) then + +! if(ib.eq.1.or.ib.eq.2.or.ib.eq.3.or.ib.eq.4.or.ib.eq.5 +! @ .or.ib.eq.6.or.ib.eq.7.or.ib.eq.8.or.ib.eq.9) then +! open( 1, file= +! @ dircurtis//'taul'//isotcode//dn//ibcode1//'.dat') +! else +! open( 1, file= +! @ dircurtis//'taul'//isotcode//dn//ibcode2//'.dat') +! endif + +! !write(1,*) dummy +! !write(1,*) 'tij for curtis matrix calculations ' +! !write(1,*)' cira mars model atmosphere ' +! write(1,*)' beta= ',beta,'deltanu= ',deltanux +! write(1,*)' number of elements (in,ir)= ',nl,nl +! write(1,*)' format: (tauinf(in),(tau(in,ir),ir=1,nl),in=1,nl)' + +! do in=1,nl +! write (1,*) tauinf(in) +! do ir=1,nl +! write(1,*) tau(in,ir) +! end do +! end do +! close(unit=1) + +! if(ib.eq.1.or.ib.eq.2.or.ib.eq.3.or.ib.eq.4.or.ib.eq.5 +! @ .or.ib.eq.6.or.ib.eq.7.or.ib.eq.8.or.ib.eq.9) then +! write (*,'(1x, 31htransmitances written out in: ,a22)') +! @ 'taul'//isotcode//dn//ibcode1 +! else +! write (*,'(1x, 31htransmitances written out in: ,a22)') +! @ 'taul'//isotcode//dn//ibcode2 +! endif + + end if + +c cleaning of transmittances +! call elimin_tau(tau,tauinf,nl,nan,itableout,nw,dummy, +! @ isotcode,dn,ibcode2) + +c construction of the curtis matrix + + call mzcf ( tauinf,tau, cf,cfup,cfdw, vc,taugr, + @ ib,isot,icfout,itableout ) + + +c end + return + end + + + + +c*********************************************************************** +c mzcf +c*********************************************************************** + + subroutine mzcf( tauinf,tau, c,cup,cdw,vc,taugr, + @ ib,isot,icfout,itableout ) + +c a.k.murphy method to avoid extrapolation in the curtis matrix +c feb-89 m. angel granada +c 25-sept-96 cristina dejar las matrices en doble precision +c jan 98 malv version para mz1d +c jul 2011 malv+fgg adapted to LMD-MGCM +c*********************************************************************** + + implicit none + + include 'comcstfi.h' + include 'nlte_paramdef.h' + include 'nlte_commons.h' + +c arguments + real*8 c(nl,nl), cup(nl,nl), cdw(nl,nl) ! o + real*8 vc(nl), taugr(nl) ! o + real*8 tau(nl,nl) ! i + real*8 tauinf(nl) ! i + integer ib ! i + integer isot ! i + integer icfout, itableout ! i + +c external + external bandid + character*2 bandid + +c local variables + integer i, in, ir, iw + real*8 cfup(nl,nl), cfdw(nl,nl) + real*8 a(nl,nl), cf(nl,nl) + character isotcode*2, bcode*2 + +c formats + 101 format(i1) + 202 format(i2) + 180 format(a80) + 181 format(a80) +c*********************************************************************** + + if (isot.eq.1) isotcode = '26' + if (isot.eq.2) isotcode = '28' + if (isot.eq.3) isotcode = '36' + if (isot.eq.4) isotcode = '27' + if (isot.eq.5) isotcode = 'co' + bcode = bandid( ib ) + +! write (*,*) ' ' + + do in=1,nl + + do ir=1,nl + + cf(in,ir) = 0.0d0 + cfup(in,ir) = 0.0d0 + cfdw(in,ir) = 0.0d0 + c(in,ir) = 0.0d0 + cup(in,ir) = 0.0d0 + cdw(in,ir) = 0.0d0 + a(in,ir) = 0.0d0 + + end do + + vc(in) = 0.0d0 + taugr(in) = 0.0d0 + + end do + + +c the next lines are a reduced and equivalent way of calculating +c the c(in,ir) elements for n=2,nl1 and r=1,nl + + +c do in=2,nl1 +c do ir=1,nl +c if(ir.eq.1)then +c c(in,ir)=tau(in-1,1)-tau(in+1,1) +c elseif(ir.eq.nl)then +c c(in,ir)=tau(in+1,nl1)-tauinf(in+1)-tau(in-1,nl1)+tauinf(in-1) +c else +c c(in,ir)=tau(in+1,ir-1)-tau(in+1,ir)-tau(in-1,ir-1)+tau(in-1,ir) +c end if +c c(in,ir)=c(in,ir)*pi*deltanu(ib)/(2.*deltaz*1.0e5) +c end do +c end do +c go to 1000 + +c calculation of the matrix cfup(nl,nl) + + cfup(1,1) = 1.d0 - tau(1,1) + + do in=2,nl + do ir=1,in + + if (ir.eq.1) then + cfup(in,ir) = tau(in,ir) - tau(in,1) + elseif (ir.eq.in) then + cfup(in,ir) = 1.d0 - tau(in,ir-1) + else + cfup(in,ir) = tau(in,ir) - tau(in,ir-1) + end if + + end do + end do + +! contribution to upwards fluxes from bb at bottom : + do in=1,nl + taugr(in) = tau(in,1) + enddo + +c calculation of the matrix cfdw(nl,nl) + + cfdw(nl,nl) = 1.d0 - tauinf(nl) + + do in=1,nl-1 + do ir=in,nl + + if (ir.eq.in) then + cfdw(in,ir) = 1.d0 - tau(in,ir) + elseif (ir.eq.nl) then + cfdw(in,ir) = tau(in,ir-1) - tauinf(in) + else + cfdw(in,ir) = tau(in,ir-1) - tau(in,ir) + end if + + end do + end do + + +c calculation of the matrix cf(nl,nl) + + do in=1,nl + do ir=1,nl + + if (ir.eq.1) then + ! version con l_bb(tg) = l_bb(t(1))=j(1) (see also vc below) + ! cf(in,ir) = tau(in,ir) + ! version con l_bb(tg) =/= l_bb(t(1))=j(1) (see also vc below) + cf(in,ir) = tau(in,ir) - tau(in,1) + elseif (ir.eq.nl) then + cf(in,ir) = tauinf(in) - tau(in,ir-1) + else + cf(in,ir) = tau(in,ir) - tau(in,ir-1) + end if + + end do + end do + + +c definition of the a(nl,nl) matrix + + do in=2,nl-1 + do ir=1,nl + if (ir.eq.in+1) a(in,ir) = -1.d0 + if (ir.eq.in-1) a(in,ir) = +1.d0 + a(in,ir) = a(in,ir) / ( 2.d0*deltaz*1.d5 ) + end do + end do +! this is not needed anymore in the akm scheme +! a(1,1) = +3.d0 +! a(1,2) = -4.d0 +! a(1,3) = +1.d0 +! a(nl,nl) = -3.d0 +! a(nl,nl1) = +4.d0 +! a(nl,nl2) = -1.d0 + +c calculation of the final curtis matrix ("reduced" by murphy's method) + + if (isot.ne.5) then + do in=1,nl + do ir=1,nl + cf(in,ir) = cf(in,ir) * pi*deltanu(isot,ib) + cfup(in,ir) = cfup(in,ir) * pi*deltanu(isot,ib) + cfdw(in,ir) = cfdw(in,ir) * pi*deltanu(isot,ib) + end do + taugr(in) = taugr(in) * pi*deltanu(isot,ib) + end do + else + do in=1,nl + do ir=1,nl + cf(in,ir) = cf(in,ir) * pi*deltanuco + enddo + taugr(in) = taugr(in) * pi*deltanuco + enddo + endif + + do in=2,nl-1 + + do ir=1,nl + + do i=1,nl + ! only c contains the matrix a. matrixes cup,cdw dont because + ! these two will be used for flux calculations, not + ! only for flux divergencies + + c(in,ir) = c(in,ir) + a(in,i) * cf(i,ir) + ! from this matrix we will extract (see below) the + ! nl2 x nl2 "core" for the "reduced" final curtis matrix. + + end do + cup(in,ir) = cfup(in,ir) + cdw(in,ir) = cfdw(in,ir) + + end do + ! version con l_bb(tg) = l_bb(t(1))=j(1) (see cf above) + !vc(in) = c(in,1) + ! version con l_bb(tg) =/= l_bb(t(1))=j(1) (see cf above) + vc(in) = pi*deltanu(isot,ib)/( 2.d0*deltaz*1.d5 ) * + @ ( tau(in-1,1) - tau(in+1,1) ) + + end do + + 5 continue + +! write (*,*) 'mztf/1/ c(2,*) =', (c(2,i), i=1,nl) + +! call elimin_dibuja(c,nl,itableout) + +c ventana del smoothing de c es nw=3 y de vc es 5 (puesto en lisa): +c subroutine elimin_mz4(c,vc,ilayer,nl,nan,iw, nw) + + iw = nan + if (isot.eq.4) iw = 5 + call elimin_mz1d (c,vc,0,iw,itableout,nw) + +! upper boundary condition +! j'(nl) = j'(nl1) ==> j(nl) = 2j(nl1) - j(nl2) ==> + do in=2,nl-1 + c(in,nl-2) = c(in,nl-2) - c(in,nl) + c(in,nl-1) = c(in,nl-1) + 2.d0*c(in,nl) + cup(in,nl-2) = cup(in,nl-2) - cup(in,nl) + cup(in,nl-1) = cup(in,nl-1) + 2.d0*cup(in,nl) + cdw(in,nl-2) = cdw(in,nl-2) - cdw(in,nl) + cdw(in,nl-1) = cdw(in,nl-1) + 2.d0*cdw(in,nl) + end do +! j(nl) = j(nl1) ==> +! do in=2,nl1 +! c(in,nl1) = c(in,nl1) + c(in,nl) +! end do + +! 1000 continue + + if (icfout.eq.1) then + +! if (ib.eq.1 .or. ib.eq.12 .or. ib.eq.16 .or. ib.eq.18) then +! codmatrx = codmatrx_fb +! else +! codmatrx = codmatrx_hot +! end if + +! if(ib.eq.1.or.ib.eq.2.or.ib.eq.3.or.ib.eq.4.or.ib.eq.5 +! @ .or.ib.eq.6.or.ib.eq.7.or.ib.eq.8.or.ib.eq.9) then + +! open ( 1, access='sequential', form='unformatted', file= +! @ dircurtis//'cfl'//isotcode//dn//ibcode1//codmatrx//'.dat') +! open ( 2, access='sequential', form='unformatted', file= +! @ dircurtis//'cflup'//isotcode//dn//ibcode1//codmatrx//'.dat') +! open ( 3, access='sequential', form='unformatted', file= +! @ dircurtis//'cfldw'//isotcode//dn//ibcode1//codmatrx//'.dat') + +! else + +! open ( 1, access='sequential', form='unformatted', file= +! @ dircurtis//'cfl'//isotcode//dn//ibcode2//codmatrx//'.dat') +! open ( 2, access='sequential', form='unformatted', file= +! @ dircurtis//'cflup'//isotcode//dn//ibcode2//codmatrx//'.dat') +! open ( 3, access='sequential', form='unformatted', file= +! @ dircurtis//'cfldw'//isotcode//dn//ibcode2//codmatrx//'.dat') + +! endif + +! write(1) dummy +! write(1)' format: (vc(n),(ch(n,r),r=2,nl-1),n=2,nl-1)' +! do in=2,nl-1 +! write(1) vc(in), (c(in,ir) , ir=2,nl-1 ) + ! es mas importante la precision que ocupar mucho espacio asi que + ! escribiremos las matrices en doble precision y por tanto en + ! [lib]readc_mz4.for no hay que reconvertirlas a doble precision. + ! ch is stored in single prec. to save storage space. +! end do + +! write(2) dummy +! write(2)' format: (cfup(n,r),r=1,nl), n=1,nl)' +! do in=1,nl +! write(2) ( cup(in,ir) , ir=1,nl ) +! end do + +! write(3) dummy +! write(3)' format: (cfdw(n,r),r=1,nl), n=1,nl)' +! do in=1,nl +! write(3) (cdw(in,ir) , ir=1,nl ) +! end do + +! if(ib.eq.1.or.ib.eq.2.or.ib.eq.3.or.ib.eq.4.or.ib.eq.5 +! @ .or.ib.eq.6.or.ib.eq.7.or.ib.eq.8.or.ib.eq.9) then +! write (*,'(1x,30hcurtis matrix written out in: ,a50)' ) +! @ dircurtis//'cfl'//isotcode//dn//ibcode1//codmatrx//'.dat' +! else +! write (*,'(1x,30hcurtis matrix written out in: ,a50)' ) +! @ dircurtis//'cfl'//isotcode//dn//ibcode2//codmatrx//'.dat' +! endif + + else + + ! write (*,*) ' no curtis matrix output file ', char(10) + + end if + + +c end + return + end + + + + + +c*********************************************************************** +c cm15um_hb_simple +c*********************************************************************** + + subroutine cm15um_hb_simple (ig,icurt) + +c computing the curtix matrixes for the 15 um hot bands +c (las de las bandas fudnamentales las calcula cm15um_fb) + +c jan 98 malv version de mod3/cm_15um.f para mz1d +c jul 2011 malv+fgg adapted to LMD-MGCM +c*********************************************************************** + + implicit none + +!!!!!!!!!!!!!!!!!!!!!!! +! common variables & constants + + include 'nlte_paramdef.h' + include 'nlte_commons.h' + +!!!!!!!!!!!!!!!!!!!!!!! +! arguments + + integer ig ! ADDED FOR TRACEBACK + integer icurt ! icurt=0,1,2 + ! new calculations? (see caa.f heads) + +!!!!!!!!!!!!!!!!!!!!!!! +! local variables + + real*4 cdummy(nl,nl), csngl(nl,nl) + + real*8 cax1(nl,nl), cax2(nl,nl), cax3(nl,nl) + real*8 v1(nl), v2(nl), v3(nl), cm_factor, vc_factor + + integer itauout,icfout,itableout, interpol,ismooth, isngldble + integer i,j,ik,ist,isot,ib,itt + + !character bandcode*2 + character isotcode*2 + character codmatrx_hot*5 + +!!!!!!!!!!!!!!!!!!!!!!! +! external functions + + external bandid + character*2 bandid + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! subroutines called: +! mz4sub, dmzout, readc_mz4, readcupdw, mztf + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! formatos + 132 format(i2) + +************************************************************************ +************************************************************************ + + call zerom (c121,nl) + + call zerov (vc121,nl) + + call zerom (cup121,nl) + call zerom (cdw121,nl) + + call zerov (taugr121,nl) + + + itauout = 0 ! =1 --> with output of tau + icfout = 0 ! =1 --> with output of cf + itableout = 0 ! =1 --> with output of table of taus + isngldble = 1 ! =1 --> dble precission + + codmatrx_hot=' ' + if (icurt.eq.2) then + icfout=1 + elseif (icurt.eq.0) then + write (*,'(a,a$)') + @ ' hot bands. code for old matrixes (5 chars): ' + read (*,'(a)') codmatrx_hot + endif + + fileroot = 'cfl' + +! ====================== curtis matrixes for fh bands ================== + + +! una piedra en el camino ... +! write (*,*) ' cm15um_hb/1 ' + +ccc + if ( input_cza.ge.1 ) then +ccc + + if (icurt.eq.2) then + write (*,'(a,a$)') + @ ' new calculation of curt. mat. for fh bands.', + @ ' code for new matrixes : ' + read (*,'(a)') codmatrx_hot + elseif (icurt.eq.0) then + write (*,'(a,a$)') + @ ' reading in curt. mat. for fh bands.', + @ ' code for old matrixes : ' + read (*,'(a)') codmatrx_hot + else +! write (*,'(a)') +! @ ' new calculation of curt. mat. for fh bands.' + end if + +! fh bands for the 626 isotope ================================- + + ist = 1 + isot = 26 +! encode (2,132,isotcode) isot + write (isotcode,132) isot + + do 11, ik=1,3 + + ib=ik+1 + + if (icurt.gt.0) then + call zero3m (cax1,cax2,cax3,nl) +! una piedra en el camino ... + !write (*,*) ' cm15um_hb/11 ' + !write (*,*) ' ib, ist, irw, imu =', ib, ist, irw_mztf, imu + call mztf ( ig,cax1,cax2,cax3,v1,v2, ib,ist,irw_mztf,imu, + @ itauout,icfout,itableout) +! else +! bandcode = bandid(ib) +! filend=isotcode//dn//bandcode//codmatrx_hot +!! write (*,*) char(9), fileroot//filend +! call zero3m (cax1,cax2,cax3,nl) +! call readcud_mz1d ( cax1,cax2,cax3, v1, v2, +! @ fileroot,filend, csngl, nl,nan,0,isngldble) + end if + +c calculating the total c121(n,r) matrix for the first hot band + do i=1,nl + + if ( ib .eq. 4 ) then +! write (*,*) ' ' +! write (*,*) i, ' ib,ist, altura :', ib,ist, zl(i) + endif + +! if ( v1(i) .le. 1.d-99 ) v1(i) = 0.0d0 +! if ( v2(i) .le. 1.d-99 ) v2(i) = 0.0d0 + + + if(ik.eq.1)then + cm_factor = (dble(618.03/667.75))**2.d0* + @ exp( dble(ee*(667.75-618.03)/t(i)) ) + vc_factor = dble(667.75/618.03) + elseif(ik.eq.2)then + cm_factor = 1.d0 + vc_factor = 1.d0 + elseif(ik.eq.3)then + cm_factor = ( dble(720.806/667.75) )**2.d0* + @ exp( dble(ee*(667.75-720.806)/t(i)) ) + vc_factor = dble(667.75/720.806) + end if + do j=1,nl +! if (cax1(i,j) .le. 1.d-99 ) cax1(i,j) = 0.0d0 +! if (cax2(i,j) .le. 1.d-99 ) cax2(i,j) = 0.0d0 +! if (cax3(i,j) .le. 1.d-99 ) cax3(i,j) = 0.0d0 + c121(i,j) = c121(i,j) + cax1(i,j) * cm_factor + cup121(i,j) = cup121(i,j) + cax2(i,j) * cm_factor + cdw121(i,j) = cdw121(i,j) + cax3(i,j) * cm_factor + end do + +! write (*,*) ' i =', i +! write (*,*) ' vc_factor =', vc_factor +! write (*,*) ' v1 =', v1(i) +! write (*,*) ' v2 =', v2(i) +! write (*,*) vc121(i), taugr121(i) +! write (*,*) v1(i) * vc_factor +! write (*,*) vc121(i) + v1(i) * vc_factor + + vc121(i) = vc121(i) + v1(i) * vc_factor + + +! write (*,*) v2(i) * vc_factor +! write (*,*) taugr121(i) + v2(i) * vc_factor + + taugr121(i) = taugr121(i) + v2(i) * vc_factor + + end do + 11 continue + +ccc + end if +ccc + + + return + end + + + + + Index: trunk/LMDZ.MARS/libf/phymars/nlte_commons.h =================================================================== --- trunk/LMDZ.MARS/libf/phymars/nlte_commons.h (revision 498) +++ trunk/LMDZ.MARS/libf/phymars/nlte_commons.h (revision 498) @@ -0,0 +1,376 @@ +c**************************************************************************** +c +c Merging of different common blocks used in the new NLTE 15um param +c +c jan 2012 fgg+malv +c**************************************************************************** +c *** Old nlte_atm.h *** +c Subgrid atmosphere interpolated +c + common /atm_nl/ zl, t, pl, sh, nt, co2, n2, co, o3p, o2, h2, ar, + @ co2vmr, n2vmr, covmr, o3pvmr,hrkday_factor + + real zl(nl), t(nl), pl(nl), nt(nl), sh(nl), + @ co2(nl), n2(nl), co(nl), o3p(nl), o2(nl), h2(nl), ar(nl), + @ co2vmr(nl),n2vmr(nl),covmr(nl),o3pvmr(nl),hrkday_factor(nl) + +c Subgrid atmosphere obtained from the input atmosphere and limited to the +c NLTE grid. Only used for computing transmitances. +c + common /atm_ny/ zy, ty, py, nty, co2y, coy + real zy(nzy), ty(nzy), py(nzy), nty(nzy), co2y(nzy), coy(nzy) + +c + common/deltazetas/ deltaz, deltazy, + @ jlowerboundary, jtopboundary + real deltaz, deltazy + integer jlowerboundary, jtopboundary + + +c *** Old nlte_results.h *** +c Next common: parameter that decides which level populations +c are already known and therefore are read and used in this program. + common/input_avilable_from/ input_cza, input_czb, input_czc, + @ input_czco + integer input_cza, input_czb, input_czc, input_czco + +c temperatura vibracional de entrada: + common/temp626/ v626t1,v626t2,v626t3,v626t4, + @ v626t5,v626t6,v626t7,v626t8 + common/temp628/ v628t1, v628t2, v628t3, v628t4 + common/temp636/ v636t1, v636t2, v636t3, v636t4 + common/temp627/ v627t1, v627t2, v627t3, v627t4 + common/tempco/ vcot1, vcot2, vcot3, vcot4, v63t1,v63t2,v63t3 + real*8 v626t4(nl), v628t4(nl), v636t4(nl), v627t4(nl) + real*8 v626t1(nl), v626t2(nl), v626t3(nl) + real*8 v626t5(nl), v626t6(nl), v626t7(nl), v626t8(nl) + real*8 v628t1(nl), v628t2(nl), v628t3(nl) + real*8 v636t1(nl), v636t2(nl), v636t3(nl) + real*8 v627t1(nl), v627t2(nl), v627t3(nl) + real*8 vcot1(nl), vcot2(nl), vcot3(nl), vcot4(nl) + real*8 v63t1(nl), v63t2(nl), v63t3(nl) + +c output de cza.for + common /tv15um/ vt11, vt12, vt13, + @ vt21, vt22, vt23, + @ vt31, vt32, vt33, + @ vt41, vt42, vt43 + real*8 vt11(nl), vt12(nl), vt13(nl), + @ vt21(nl), vt22(nl), vt23(nl), + @ vt31(nl), vt32(nl), vt33(nl), + @ vt41(nl), vt42(nl), vt43(nl) + + common /hr15um/ hr110,hr210,hr310,hr410, + @ hr121,hr221,hr321,hr421, + @ hr132,hr232,hr332,hr432 + real*8 hr110(nl),hr121(nl),hr132(nl), + @ hr210(nl),hr310(nl),hr410(nl), + @ hr221(nl),hr232(nl),hr321(nl), + @ hr332(nl),hr421(nl),hr432(nl) + + common/sf15um/ el11,el12,el13, el21,el22,el23, + @ el31,el32,el33, el41,el42,el43 + real*8 el11(nl), el12(nl), el13(nl) + real*8 el21(nl), el22(nl), el23(nl) + real*8 el31(nl), el32(nl), el33(nl) + real*8 el41(nl), el42(nl), el43(nl) + + common/sl15um/ sl110,sl121,sl132, sl210,sl221,sl232, + @ sl310,sl321,sl332, sl410,sl421,sl432 + real*8 sl110(nl), sl121(nl), sl132(nl) + real*8 sl210(nl), sl221(nl), sl232(nl) + real*8 sl310(nl), sl321(nl), sl332(nl) + real*8 sl410(nl), sl421(nl), sl432(nl) + + +c *** Old nlte_matrix.h*** +c curtis matrix de cza: + common/curtis_matrixes_15um/ c110,c121, c210, + @ c310, c410, + @ vc110,vc121, vc210, + @ vc310, vc410 + real*8 c110(nl,nl), c121(nl,nl) + real*8 c210(nl,nl) + real*8 c310(nl,nl) + real*8 c410(nl,nl) + real*8 vc110(nl), vc121(nl) + real*8 vc210(nl), vc310(nl), vc410(nl) + + common/curtis_matr_up_15um/ + @ cup110,cup121 + real*8 cup110(nl,nl), cup121(nl,nl) + + common/curtis_matr_dw_15um/ + @ cdw110,cdw121 + real*8 cdw110(nl,nl), cdw121(nl,nl) + + common/curtis_matr_taugr_15um/ + @ taugr110,taugr121 + real*8 taugr110(nl), taugr121(nl) + +! for the new flux formulation: +! +! + common/tauinf_15um/ tauinf121, + @ tauinf210,tauinf310,tauinf410,tauinf110 + real*8 tauinf121(nl) + real*8 tauinf210(nl), tauinf310(nl), tauinf410(nl) + real*8 tauinf110(nl) + +! for the cool-to-space formulation: +! + common/taustar_15um/ taustar11, taustar21, taustar31, + @ taustar41, taustar12 + real*8 taustar11(nl), taustar21(nl), taustar31(nl) + real*8 taustar41(nl), taustar12(nl) + + common/tauii_15um/ tauii110, tauii210, tauii310, + @ tauii410, tauii121 + real*8 tauii110(nl), tauii210(nl), tauii310(nl) + real*8 tauii410(nl), tauii121(nl) + +! for the name of the C.Matrix files +! + common/cm_names/ fileroot + character fileroot*3 + + +c *** Old nlte_rates.h *** + common/rates_vt/ k7a(4),k7b(4), k7ap(4),k7bp(4), + @ k3aa(4),k3ab(4),k3ac(4), k3aap(4),k3abp(4),k3acp(4), + @ k3ba(4),k3bb(4),k3bc(4), k3bap(4),k3bbp(4),k3bcp(4), + @ k19aa(4),k19ab(4),k19ac(4), k19aap(4),k19abp(4),k19acp(4), + @ k19ba(4),k19bb(4),k19bc(4), k19bap(4),k19bbp(4),k19bcp(4), + @ k19ca(4),k19cb(4),k19cc(4), k19cap(4),k19cbp(4),k19ccp(4), + @ k20a(4),k20b(4),k20c(4), k20ap(4),k20bp(4),k20cp(4), + @ k27a,k27b,k27c, k27ap,k27bp,k27cp + + real*8 k7a,k7b, k7ap,k7bp + real*8 k3aa,k3ab,k3ac, k3aap,k3abp,k3acp + real*8 k3ba,k3bb,k3bc, k3bap,k3bbp,k3bcp + real*8 k19aa,k19ab,k19ac, k19aap,k19abp,k19acp + real*8 k19ba,k19bb,k19bc, k19bap,k19bbp,k19bcp + real*8 k19ca,k19cb,k19cc, k19cap,k19cbp,k19ccp + real*8 k20a,k20b,k20c, k20ap,k20bp,k20cp + real*8 k27a,k27b,k27c, k27ap,k27bp,k27cp + + common/rates_vv/ k1(4),k1p(4), + @ k2a,k2b, k2x,k2y,k2z, k2xp,k2yp,k2zp, + @ k6,k6p, k6a(2:4),k6b(2:4), k6ap(2:4),k6bp(2:4), + @ k21a,k21ap, k21a1(2:4),k21a2(2:4), k21a1p(2:4),k21a2p(2:4), + @ k21b(4),k21c(4), k21bp(4),k21cp(4), + @ k31,k32, + @ k33a1,k33a2,k33b1,k33b2,k33c, + @ k33a1p(2:4),k33a2p(2:4),k33b1p(2:4),k33b2p(2:4),k33cp(2:4), + @ k28a,k28b,k28c, k28ap,k28bp,k28cp, + @ k26a,k26b,k26c,k26d, k26ap(4),k26bp(4),k26cp(4),k26dp(4), + @ k41p_taylor, k41p_shved, k41p_starr_hannock, + @ k41_1,k41p_1, k41_2,k41p_2, k42,k42p + + real*8 k1,k1p + real*8 k2a,k2b, k2x,k2y,k2z, k2xp,k2yp,k2zp + real*8 k6,k6p, k6a,k6b, k6ap,k6bp + real*8 k21a,k21ap, k21a1,k21a2, k21a1p,k21a2p + real*8 k21b,k21c, k21bp,k21cp + real*8 k31,k32 + real*8 k33a1,k33a2,k33b1,k33b2,k33c + real*8 k33a1p,k33a2p,k33b1p,k33b2p,k33cp + real*8 k28a,k28b,k28c, k28ap,k28bp,k28cp + real*8 k26a,k26b,k26c,k26d, k26ap,k26bp,k26cp,k26dp + real*8 k41p_taylor, k41p_shved, k41p_starr_hannock + real*8 k41_1,k41p_1, k41_2,k41p_2, k42,k42p + + + common/rates_k26isot/ k26a21,k26c21,k26d21, + @ k26a22,k26c22,k26d22, k26a23,k26c23,k26d23, + @ k26a24,k26c24,k26d24, + @ k26a32,k26c32,k26d32, k26a33,k26c33,k26d33, + @ k26a31,k26c31,k26d31, + @ k26a34,k26c34,k26d34, k26a42,k26c42,k26d42, + @ k26a41,k26c41,k26d41, + @ k26a43,k26c43,k26d43, k26a44,k26c44,k26d44 + + real*8 k26a21,k26c21,k26d21, + @ k26a22,k26c22,k26d22, k26a23,k26c23,k26d23, + @ k26a24,k26c24,k26d24, + @ k26a32,k26c32,k26d32, k26a33,k26c33,k26d33, + @ k26a31,k26c31,k26d31, + @ k26a34,k26c34,k26d34, k26a42,k26c42,k26d42, + @ k26a41,k26c41,k26d41, + @ k26a43,k26c43,k26d43, k26a44,k26c44,k26d44 + + + common/rates_last/ k23k21c, k24k21c, k34k21c, + @ k23k21cp, k24k21cp, k34k21cp, k43,k43p, k_vthcl + + real*8 k23k21c,k24k21c,k34k21c, k23k21cp,k24k21cp,k34k21cp + real*8 k43,k43p, k_vthcl + + common/rates_V09/ k41_3,k41p_3, k41_4,k41p_4, k41iso_1,k41iso_1p, + @ k41iso_2,k41iso_2p, k41iso_3,k41iso_3p, + @ k42b, k42c, k42bp, k42cp, k43iso,k43isop, + @ k44a,k44b,k44c,k44d, k44ap,k44bp,k44cp,k44dp, + @ k42iso,k42isop, k42isob,k42isobp + real*8 k41_3,k41p_3, k41_4,k41p_4, k41iso_1,k41iso_1p + real*8 k41iso_2,k41iso_2p, k41iso_3,k41iso_3p + real*8 k42b, k42c, k42bp, k42cp, k43iso,k43isop + real*8 k44a,k44b,k44c,k44d, k44ap,k44bp,k44cp,k44dp + real*8 k42iso,k42isop, k42isob,k42isobp + + +c *** Old nlte_curtis.h *** + + + common/block1/s,alsa,alna,alda,ka,kr + real*8 ka(nbox_max),alsa(nbox_max),alna(nbox_max),alda(nbox_max) + &,s + integer kr + + common/block2/hisfile, hfile1 + character hisfile*75, hfile1*3 + + common/block3/sl_ua,ua,pt,pp,ta,w, icls + real*8 sl_ua,ua(nbox_max),pt,pp,ta(nbox_max),w + integer icls + + common/block4/no,sk1,xls1,xln1,xld1,thist,dist, nbox + real*8 sk1(nhist,nbox_max) ! line intensity + real*8 xls1(nhist,nbox_max) ! Lorentz half width (self-col.) + real*8 xln1(nhist,nbox_max) ! Lorentz half width + real*8 xld1(nhist,nbox_max) ! Doppler half width + real*8 thist(nhist) ! temperatures in the histogram + real*8 no(nbox_max) ! number of lines in box + real*8 dist(nbox_max) ! mean distance between lines in box + integer nbox ! actual number of boxes + + common/block5/eqw, aa, bb, cc, dd, ddbox, ccbox + real*8 eqw, aa, bb, cc, dd + real*8 ddbox(nbox_max), ccbox(nbox_max) + + common/block7/ mr, p + real*8 mr(nzy), p(nzy) + + common/block8/ tmin,tmax, mm + real*8 tmin,tmax + integer mm + + common/block9/ w_strongLor_prev + real*8 w_strongLor_prev(nbox_max) + + common/block10/no_c1,no_c2,no_c3,no_c4,no_c5,no_c6,no_c7 + real*8 no_c1(nbox_max) + real*8 no_c2(nbox_max) + real*8 no_c3(nbox_max) + real*8 no_c4(nbox_max) + real*8 no_c5(nbox_max) + real*8 no_c6(nbox_max) + real*8 no_c7(nbox_max) + + common/block11/nbox_c1,nbox_c2,nbox_c3,nbox_c4, + $ nbox_c5,nbox_c6,nbox_c7 + integer nbox_c1 + integer nbox_c2 + integer nbox_c3 + integer nbox_c4 + integer nbox_c5 + integer nbox_c6 + integer nbox_c7 + + common/block12/thist_c1,thist_c2,thist_c3,thist_c4,thist_c5, + $ thist_c6,thist_c7 + real*8 thist_c1(nhist) + real*8 thist_c2(nhist) + real*8 thist_c3(nhist) + real*8 thist_c4(nhist) + real*8 thist_c5(nhist) + real*8 thist_c6(nhist) + real*8 thist_c7(nhist) + + common/block13/dist_c1,dist_c2,dist_c3,dist_c4,dist_c5, + $ dist_c6,dist_c7 + real*8 dist_c1(nbox_max) + real*8 dist_c2(nbox_max) + real*8 dist_c3(nbox_max) + real*8 dist_c4(nbox_max) + real*8 dist_c5(nbox_max) + real*8 dist_c6(nbox_max) + real*8 dist_c7(nbox_max) + + common/block14/sk1_c1,sk1_c2,sk1_c3,sk1_c4,sk1_c5,sk1_c6,sk1_c7 + real*8 sk1_c1(nhist,nbox_max) + real*8 sk1_c2(nhist,nbox_max) + real*8 sk1_c3(nhist,nbox_max) + real*8 sk1_c4(nhist,nbox_max) + real*8 sk1_c5(nhist,nbox_max) + real*8 sk1_c6(nhist,nbox_max) + real*8 sk1_c7(nhist,nbox_max) + + common/block15/xls1_c1,xls1_c2,xls1_c3,xls1_c4,xls1_c5,xls1_c6, + $ xls1_c7 + real*8 xls1_c1(nhist,nbox_max) + real*8 xls1_c2(nhist,nbox_max) + real*8 xls1_c3(nhist,nbox_max) + real*8 xls1_c4(nhist,nbox_max) + real*8 xls1_c5(nhist,nbox_max) + real*8 xls1_c6(nhist,nbox_max) + real*8 xls1_c7(nhist,nbox_max) + + common/block16/xln1_c1,xln1_c2,xln1_c3,xln1_c4,xln1_c5,xln1_c6, + $ xln1_c7 + real*8 xln1_c1(nhist,nbox_max) + real*8 xln1_c2(nhist,nbox_max) + real*8 xln1_c3(nhist,nbox_max) + real*8 xln1_c4(nhist,nbox_max) + real*8 xln1_c5(nhist,nbox_max) + real*8 xln1_c6(nhist,nbox_max) + real*8 xln1_c7(nhist,nbox_max) + + common/block17/xld1_c1,xld1_c2,xld1_c3,xld1_c4,xld1_c5,xld1_c6, + $ xld1_c7 + real*8 xld1_c1(nhist,nbox_max) + real*8 xld1_c2(nhist,nbox_max) + real*8 xld1_c3(nhist,nbox_max) + real*8 xld1_c4(nhist,nbox_max) + real*8 xld1_c5(nhist,nbox_max) + real*8 xld1_c6(nhist,nbox_max) + real*8 xld1_c7(nhist,nbox_max) + + common/block18/mm_c1,mm_c2,mm_c3,mm_c4,mm_c5,mm_c6,mm_c7 + integer mm_c1 + integer mm_c2 + integer mm_c3 + integer mm_c4 + integer mm_c5 + integer mm_c6 + integer mm_c7 + + common/block19/tmin_c1,tmin_c2,tmin_c3,tmin_c4,tmin_c5,tmin_c6, + $ tmin_c7 + real*8 tmin_c1 + real*8 tmin_c2 + real*8 tmin_c3 + real*8 tmin_c4 + real*8 tmin_c5 + real*8 tmin_c6 + real*8 tmin_c7 + + common/block20/tmax_c1,tmax_c2,tmax_c3,tmax_c4,tmax_c5,tmax_c6, + $ tmax_c7 + real*8 tmax_c1 + real*8 tmax_c2 + real*8 tmax_c3 + real*8 tmax_c4 + real*8 tmax_c5 + real*8 tmax_c6 + real*8 tmax_c7 + + common /lor_overlap/ asat_box, i_supersat + real*8 asat_box + integer i_supersat + + +c *** Variables formerly included in nlte_data.h *** + common /nltedata/ elow, deltanu + real elow(nisot,nb), deltanu(nisot,nb) + +c**************************************************************************** Index: trunk/LMDZ.MARS/libf/phymars/nlte_curtis.h =================================================================== --- trunk/LMDZ.MARS/libf/phymars/nlte_curtis.h (revision 496) +++ (revision ) @@ -1,155 +1,0 @@ -c**************************************************************************** -c -c curtis.cmn -c -c Common blocks for Curtis Matrix calculation -c -c JAN 98 MALV First version -c**************************************************************************** - - - common/block1/s,alsa,alna,alda,ka,kr - real*8 ka(nbox_max),alsa(nbox_max),alna(nbox_max),alda(nbox_max),s - integer kr - - common/block2/hisfile, hfile1 - character hisfile*75, hfile1*3 - - common/block3/sl_ua,ua,pt,pp,ta,w, icls - real*8 sl_ua,ua(nbox_max),pt,pp,ta(nbox_max),w - integer icls - - common/block4/no,sk1,xls1,xln1,xld1,thist,dist, nbox - real*8 sk1(nhist,nbox_max) ! line intensity - real*8 xls1(nhist,nbox_max) ! Lorentz half width (self-col.) - real*8 xln1(nhist,nbox_max) ! Lorentz half width - real*8 xld1(nhist,nbox_max) ! Doppler half width - real*8 thist(nhist) ! temperatures in the histogram - real*8 no(nbox_max) ! number of lines in box - real*8 dist(nbox_max) ! mean distance between lines in box - integer nbox ! actual number of boxes - - common/block5/eqw, aa, bb, cc, dd, ddbox, ccbox - real*8 eqw, aa, bb, cc, dd - real*8 ddbox(nbox_max), ccbox(nbox_max) - - common/block7/ mr, p - real*8 mr(nzy), p(nzy) - - common/block8/ tmin,tmax, mm - real*8 tmin,tmax - integer mm - - common/block9/ w_strongLor_prev - real*8 w_strongLor_prev(nbox_max) - - common/block10/no_c1,no_c2,no_c3,no_c4,no_c5,no_c6,no_c7 - real*8 no_c1(nbox_max) - real*8 no_c2(nbox_max) - real*8 no_c3(nbox_max) - real*8 no_c4(nbox_max) - real*8 no_c5(nbox_max) - real*8 no_c6(nbox_max) - real*8 no_c7(nbox_max) - - common/block11/nbox_c1,nbox_c2,nbox_c3,nbox_c4, - $ nbox_c5,nbox_c6,nbox_c7 - integer nbox_c1 - integer nbox_c2 - integer nbox_c3 - integer nbox_c4 - integer nbox_c5 - integer nbox_c6 - integer nbox_c7 - - common/block12/thist_c1,thist_c2,thist_c3,thist_c4,thist_c5, - $ thist_c6,thist_c7 - real*8 thist_c1(nhist) - real*8 thist_c2(nhist) - real*8 thist_c3(nhist) - real*8 thist_c4(nhist) - real*8 thist_c5(nhist) - real*8 thist_c6(nhist) - real*8 thist_c7(nhist) - - common/block13/dist_c1,dist_c2,dist_c3,dist_c4,dist_c5, - $ dist_c6,dist_c7 - real*8 dist_c1(nbox_max) - real*8 dist_c2(nbox_max) - real*8 dist_c3(nbox_max) - real*8 dist_c4(nbox_max) - real*8 dist_c5(nbox_max) - real*8 dist_c6(nbox_max) - real*8 dist_c7(nbox_max) - - common/block14/sk1_c1,sk1_c2,sk1_c3,sk1_c4,sk1_c5,sk1_c6,sk1_c7 - real*8 sk1_c1(nhist,nbox_max) - real*8 sk1_c2(nhist,nbox_max) - real*8 sk1_c3(nhist,nbox_max) - real*8 sk1_c4(nhist,nbox_max) - real*8 sk1_c5(nhist,nbox_max) - real*8 sk1_c6(nhist,nbox_max) - real*8 sk1_c7(nhist,nbox_max) - - common/block15/xls1_c1,xls1_c2,xls1_c3,xls1_c4,xls1_c5,xls1_c6, - $ xls1_c7 - real*8 xls1_c1(nhist,nbox_max) - real*8 xls1_c2(nhist,nbox_max) - real*8 xls1_c3(nhist,nbox_max) - real*8 xls1_c4(nhist,nbox_max) - real*8 xls1_c5(nhist,nbox_max) - real*8 xls1_c6(nhist,nbox_max) - real*8 xls1_c7(nhist,nbox_max) - - common/block16/xln1_c1,xln1_c2,xln1_c3,xln1_c4,xln1_c5,xln1_c6, - $ xln1_c7 - real*8 xln1_c1(nhist,nbox_max) - real*8 xln1_c2(nhist,nbox_max) - real*8 xln1_c3(nhist,nbox_max) - real*8 xln1_c4(nhist,nbox_max) - real*8 xln1_c5(nhist,nbox_max) - real*8 xln1_c6(nhist,nbox_max) - real*8 xln1_c7(nhist,nbox_max) - - common/block17/xld1_c1,xld1_c2,xld1_c3,xld1_c4,xld1_c5,xld1_c6, - $ xld1_c7 - real*8 xld1_c1(nhist,nbox_max) - real*8 xld1_c2(nhist,nbox_max) - real*8 xld1_c3(nhist,nbox_max) - real*8 xld1_c4(nhist,nbox_max) - real*8 xld1_c5(nhist,nbox_max) - real*8 xld1_c6(nhist,nbox_max) - real*8 xld1_c7(nhist,nbox_max) - - common/block18/mm_c1,mm_c2,mm_c3,mm_c4,mm_c5,mm_c6,mm_c7 - integer mm_c1 - integer mm_c2 - integer mm_c3 - integer mm_c4 - integer mm_c5 - integer mm_c6 - integer mm_c7 - - common/block19/tmin_c1,tmin_c2,tmin_c3,tmin_c4,tmin_c5,tmin_c6, - $ tmin_c7 - real*8 tmin_c1 - real*8 tmin_c2 - real*8 tmin_c3 - real*8 tmin_c4 - real*8 tmin_c5 - real*8 tmin_c6 - real*8 tmin_c7 - - common/block20/tmax_c1,tmax_c2,tmax_c3,tmax_c4,tmax_c5,tmax_c6, - $ tmax_c7 - real*8 tmax_c1 - real*8 tmax_c2 - real*8 tmax_c3 - real*8 tmax_c4 - real*8 tmax_c5 - real*8 tmax_c6 - real*8 tmax_c7 - - common /lor_overlap/ asat_box, i_supersat - real*8 asat_box - integer i_supersat Index: trunk/LMDZ.MARS/libf/phymars/nlte_data.h =================================================================== --- trunk/LMDZ.MARS/libf/phymars/nlte_data.h (revision 496) +++ (revision ) @@ -1,23 +1,0 @@ -! - common/spectral/imr, imrco, - @ nu, nun2, nuco_10, - @ nu12_0200,nu12_1000, nu22_0200,nu22_1000, - @ nu32_0200,nu32_1000, nu42_0200,nu42_1000, - @ elow, deltanu, deltanuco, indexisot - real imr(nisot), imrco - real nu(nisot,8), elow(nisot,nb), deltanu(nisot,nb) - real nun2, nu12_0200,nu12_1000, nu22_0200,nu22_1000, - @ nu32_0200,nu32_1000, nu42_0200,nu42_1000 - real nuco_10, deltanuco - integer indexisot(nisot) -! -! - common/datis/ vlight, ee, hplanck, gamma - real*8 vlight, ee, hplanck, gamma - - - - - - - Index: trunk/LMDZ.MARS/libf/phymars/nlte_leedat.F =================================================================== --- trunk/LMDZ.MARS/libf/phymars/nlte_leedat.F (revision 498) +++ trunk/LMDZ.MARS/libf/phymars/nlte_leedat.F (revision 498) @@ -0,0 +1,1147 @@ +c*********************************************************************** + subroutine NLTE_leedat + +c reads planetary and molecular parameters + +c jan 98 malv first version +c jul 2011 malv+fgg adapted to LMD-MGCM +c*********************************************************************** + + implicit none + + include 'datafile.h' + include 'nlte_paramdef.h' + include 'nlte_commons.h' + + +c local variables + integer i,j, k,lun1, lun2 + integer :: ib = 0 + integer isot + character isotcode*2 + character ibcode1*1 + +c formats + 132 format (i2) + 101 format(i1) +c*********************************************************************** + + lun1 = 1 + lun2 = 2 + + do k=1,nisot +! encode (2,132,isotcode) indexisot(k) + write (isotcode,132) indexisot(k) + open (lun1, + @ file=trim(datafile)//'/NLTEDAT/enelow'//isotcode//'.dat', + @ status='old') + open (lun2, + @ file=trim(datafile)//'/NLTEDAT/deltanu'//isotcode//'.dat', + @ status='old') + read (lun1,*) + read (lun2,*) + read (lun1,*) (elow(k,i), i=1,nb) + read (lun2,*) (deltanu(k,i), i=1,nb) + close (lun1) + close (lun2) + end do + + +c Call to rhist + + hfile1='hid' +! if (ib.eq.13 .or. ib.eq.14 ) hfile1 = dirspec//'his' + if (ib.eq.13 .or. ib.eq.14 ) hfile1 = 'his' + + ib=1 + do isot=1,4 +c Cases 1,2,3,4 + if (isot.eq.1) hisfile = hfile1//'26-1.dat' + if (isot.eq.2) hisfile = hfile1//'28-1.dat' + if (isot.eq.3) hisfile = hfile1//'36-1.dat' + if (isot.eq.4) hisfile = hfile1//'27-1.dat' + call rhist(1.0) + if (isot.eq.1) then !Case 1 + mm_c1=mm + nbox_c1=nbox + tmin_c1=tmin + tmax_c1=tmax + do i=1,nbox_max + no_c1(i)=no(i) + dist_c1(i)=dist(i) + do j=1,nhist + sk1_c1(j,i)=sk1(j,i) + xls1_c1(j,i)=xls1(j,i) + xln1_c1(j,i)=xln1(j,i) + xld1_c1(j,i)=xld1(j,i) + enddo + enddo + do j=1,nhist + thist_c1(j)=thist(j) + enddo + else if(isot.eq.2) then !Case 2 + mm_c2=mm + nbox_c2=nbox + tmin_c2=tmin + tmax_c2=tmax + do i=1,nbox_max + no_c2(i)=no(i) + dist_c2(i)=dist(i) + do j=1,nhist + sk1_c2(j,i)=sk1(j,i) + xls1_c2(j,i)=xls1(j,i) + xln1_c2(j,i)=xln1(j,i) + xld1_c2(j,i)=xld1(j,i) + enddo + enddo + do j=1,nhist + thist_c2(j)=thist(j) + enddo + else if (isot.eq.3) then ! Case 3 + mm_c3=mm + nbox_c3=nbox + tmin_c3=tmin + tmax_c3=tmax + do i=1,nbox_max + no_c3(i)=no(i) + dist_c3(i)=dist(i) + do j=1,nhist + sk1_c3(j,i)=sk1(j,i) + xls1_c3(j,i)=xls1(j,i) + xln1_c3(j,i)=xln1(j,i) + xld1_c3(j,i)=xld1(j,i) + enddo + enddo + do j=1,nhist + thist_c3(j)=thist(j) + enddo + else if (isot.eq.4) then ! Case 4 + mm_c4=mm + nbox_c4=nbox + tmin_c4=tmin + tmax_c4=tmax + do i=1,nbox_max + no_c4(i)=no(i) + dist_c4(i)=dist(i) + do j=1,nhist + sk1_c4(j,i)=sk1(j,i) + xls1_c4(j,i)=xls1(j,i) + xln1_c4(j,i)=xln1(j,i) + xld1_c4(j,i)=xld1(j,i) + enddo + enddo + do j=1,nhist + thist_c4(j)=thist(j) + enddo + endif + enddo + do ib=2,4 + isot=1 + write (ibcode1,101) ib + hisfile = hfile1//'26-'//ibcode1//'.dat' + call rhist (1.0) + if (ib.eq.2) then !Case 5 + mm_c5=mm + nbox_c5=nbox + tmin_c5=tmin + tmax_c5=tmax + do i=1,nbox_max + no_c5(i)=no(i) + dist_c5(i)=dist(i) + do j=1,nhist + sk1_c5(j,i)=sk1(j,i) + xls1_c5(j,i)=xls1(j,i) + xln1_c5(j,i)=xln1(j,i) + xld1_c5(j,i)=xld1(j,i) + enddo + enddo + do j=1,nhist + thist_c5(j)=thist(j) + enddo + else if (ib.eq.3) then !Case 6 + mm_c6=mm + nbox_c6=nbox + tmin_c6=tmin + tmax_c6=tmax + do i=1,nbox_max + no_c6(i)=no(i) + dist_c6(i)=dist(i) + do j=1,nhist + sk1_c6(j,i)=sk1(j,i) + xls1_c6(j,i)=xls1(j,i) + xln1_c6(j,i)=xln1(j,i) + xld1_c6(j,i)=xld1(j,i) + enddo + enddo + do j=1,nhist + thist_c6(j)=thist(j) + enddo + else if (ib.eq.4) then !Case 7 + mm_c7=mm + nbox_c7=nbox + tmin_c7=tmin + tmax_c7=tmax + do i=1,nbox_max + no_c7(i)=no(i) + dist_c7(i)=dist(i) + do j=1,nhist + sk1_c7(j,i)=sk1(j,i) + xls1_c7(j,i)=xls1(j,i) + xln1_c7(j,i)=xln1(j,i) + xld1_c7(j,i)=xld1(j,i) + enddo + enddo + do j=1,nhist + thist_c7(j)=thist(j) + enddo + endif + enddo + +c end + return + + end + + + +c ******************************************************************* + + subroutine rhist (factor_comp) + +c reads histogram data arrays created by ~/spectral/his.for +c malv nov-98 add average distance between lines for overlapp + +c ******************************************************************* + + + implicit none + + include 'nlte_paramdef.h' + include 'nlte_commons.h' + include 'datafile.h' + +c arguments + real factor_comp + +c local variables + integer j, r + real*8 sk1_aux, xls1_aux, xln1_aux, xld1_aux,weight,nu0 + character tonto*50 + +c formats +! 100 format(80a1) ! Esto es si fuese byte dummy(80) + 100 format(a80) ! Esto es si fuese character dummy*80 + 150 format(a50) ! Esto es si fuese character dummy*80 + +c *************** + + open(unit=3, + $ file=trim(datafile)//'/NLTEDAT/' + $ //hisfile(1:len_trim(hisfile)),status='old') + !read(3,100) dummy + read(3,150) tonto + read(3,*) weight + read(3,*) mm + read(3,*) nu0 + read(3,*) nbox + !read(3,'(a)') dumm + read(3,'(a)') tonto + + if ( nbox .gt. nbox_max ) then + write (*,*) ' nbox too large in input file ', hisfile + stop ' Check maximum number nbox_max in mz1d.par ' + endif + do 1 j=1,mm ! for each temperature + read(3,*) thist(j) + do r=1,nbox ! for each box + read(3,*) no(r), sk1(j,r), xls1(j,r),xln1(j,r),xld1(j,r), + @ dist(r) +c xld1(j,r)=xld1(j,r)*0.83255 !0.83255=sqrt(log(2)) + enddo + 1 continue + tmax=thist(1) + tmin=thist(mm) + + !close(unit=3,dispose='save') + close(unit=3) + + + do 2 j=1,mm + do r=1,nbox + sk1(j,r) = sk1(j,r) * factor_comp + enddo + 2 continue + + + return + end + + + + +c*********************************************************************** + subroutine leetvt + +c reads input vibr. temps. from external files or sets lte values +c according to the driver table + +c jul 2011 malv+fgg adapted to LMD-MGCM +c malv Jan 07 Add new vertical fine-grid for NLTE +c jan 98 malv based on solar10sub +c*********************************************************************** + + implicit none + + include 'nlte_paramdef.h' + include 'nlte_commons.h' + +c local variables + integer i + real*8 zld(nl), zyd(nzy) + real*8 xvt11(nzy), xvt21(nzy), xvt31(nzy), xvt41(nzy) + +c*********************************************************************** + + do i=1,nzy + zyd(i) = dble(zy(i)) + xvt11(i)= dble( ty(i) ) + xvt21(i)= dble( ty(i) ) + xvt31(i)= dble( ty(i) ) + xvt41(i)= dble( ty(i) ) + end do + + +c interpolate to the nlte subgrid + + do i=1,nl + zld(i) = dble( zl(i) ) + enddo + call interdp ( v626t1,zld,nl, xvt11,zyd,nzy, 1) + call interdp ( v628t1,zld,nl, xvt21,zyd,nzy, 1) + call interdp ( v636t1,zld,nl, xvt31,zyd,nzy, 1) + call interdp ( v627t1,zld,nl, xvt41,zyd,nzy, 1) + + +c end + return + end + + + +c*********************************************************************** + + subroutine getk (tt) + +c jan 98 malv version for mz1d. copied from solar10/getk.f +c jul 2011 malv+fgg adapted to LMD-MGCM +c*********************************************************************** + + implicit none + + include 'nlte_paramdef.h' + include 'nlte_commons.h' + +c arguments + real tt ! i. temperature + +!! local variables: + real*8 k1x, k7x,k7xa,k7xb + real*8 k3x, k3xaa,k3xac,k3xab,k3xbb,k3xba,k3xbc + real*8 k3xco2,k3xn2,k3xco, k6x,k6x1,k6x2 + real*8 k20x,k20xa,k20xb,k20xc + real*8 k19xca,k19xcb,k19xcc + real*8 k19xba,k19xbb,k19xbc + real*8 k19xaa,k19xab,k19xac + real*8 k21x,k21xa,k21xb,k21xc + real*8 anu, factor , k21xa_626 + real tt1,tt2, de + integer i + +c*********************************************************************** + +co2i(001) + n2 ---> co2i + n2(1) k1 (not considered in the model +c k1(i) i = 1 --- 626 +! 2 --- 636 +! 3 --- 628 +! 4 --- 627 + +! k1x = 5.d-13 * sqrt(300.d0/tt) +! do i=1,nisot +! k1(i) = k1x * rf1 +! k1p(i) = k1(i) * exp( -ee/tt *1.d0* (-nun2+nu(i,4)) ) +! end do + +co2(001) + co2i ---> co2 + co2i(001) k2 (vv1 in table 4, paper i) +c k2i i = x --- 628 +! y --- 636 +! z --- 627 + + k2a = 6.8d-12 * sqrt(tt) ! delta(e)< 42 cm-1 + k2b = 3.6d-11 * sqrt(tt) * exp(-65.6557/26.3) ! > 42 cm-1 see table 3 + k2a = k2a * rf2desac + k2b = k2b * rf2desac + + k2x = 6.8d-12 * sqrt(tt) + k2y = 3.6d-11 * sqrt(tt) * exp(-65.6557/26.3) + k2z = 6.8d-12 * sqrt(tt) + k2x = k2x * rf2iso + k2y = k2y * rf2iso + k2z = k2z * rf2iso + k2xp = k2x * exp( dble( -ee/tt * (nu(1,4)-nu(2,4)) ) ) + k2yp = k2y * exp( dble( -ee/tt * (nu(1,4)-nu(3,4)) ) ) + k2zp = k2z * exp( dble( -ee/tt * (nu(1,4)-nu(4,4)) ) ) + +! these are vt1 in table 3, paper i +co2i(001) + m ---> co2i(0v0) + m k3 +co2i(001) + o3p ---> co2i(0v0) + o3p k7 +c k3vm(i) m = a --- co2 v = a --- 3 i = 1,2,3,4 +! b --- n2,o2 b --- 2 +! c --- co +c k7v(i) v = a --- 3 i = 1,2,3,4 +! b --- 2 + + k7x = 2.0d-13*sqrt(tt/300.d0) + k7x = k7x * rf7 + + if (iopt3.eq.0) then + + k3x = 2.2d-15 + 1.14d-10 * exp( dble(-76.75/tt**(1.d0/3.d0)) ) + k3xaa = 3.0d-15 + 1.72d-10 * exp( dble(-76.75/tt**(1.d0/3.d0))) + k3xac = 2.2d-15 + 9.66d-11 * exp( dble(-76.75/tt**(1.d0/3.d0))) + k3x = k3x * rf3 + k3xaa = k3xaa * rf3 + k3xac = k3xac * rf3 + + tt1=220.0 !500.0 !220.0 + tt2=250.0 !250.0 + if(tt.le.tt1)then + k3xab = k3x + k3xbb = 0.d0 + k7xa=k7x + k7xb=0.d0 + else if(tt.gt.tt2)then + k3xab = 0.d0 + k3xbb = k3x + k7xa=0.d0 + k7xb=k7x + else + k3xab = k3x/30.d0*(tt2-tt) + k3xbb = k3x/30.d0*(tt-tt1) + k7xa=k7x/30.d0*(tt2-tt) + k7xb=k7x/30.d0*(tt-tt1) + end if + k3xba = k3xbb + k3xbc = k3xbb + + elseif (iopt3.gt.0) then ! bauer et. al., 1987 + + if (tt.ge.190. .and. tt.le.250.) then + factor = 0.9d0 + dble( (0.1-0.9)/(250.-190.) * (tt-190.) ) + elseif (tt.lt.190.) then + factor = 0.9d0 + elseif (tt.gt.250.) then + factor = 0.1d0 + end if + + k3xn2 = 2.2d-15 + 1.14d-10 * exp(dble( -76.75/tt**(1.d0/3.d0))) + k3xn2 = k3xn2 * rf3 + k3xab = k3xn2 * factor + k3xbb = k3xn2 * (1.-factor) + + k7xa = k7x * factor + k7xb = k7x * (1.-factor) + + if (iopt3.eq.1) then + + if (tt.le.148.8) then + k3xco2 = 13.8 - 0.1807 * (tt-140.) + elseif (tt.ge.148.8 .and. tt.le.159.6) then + k3xco2 = 12.21 - 0.1787 * (tt-148.8) + elseif (tt.ge.159.6 .and. tt.le.171.0) then + k3xco2 = 10.28 - 0.04035 * (tt-159.6) + elseif (tt.ge.171.0 .and. tt.le.186.4) then + k3xco2 = 9.82 - 0.027273 * (tt-171.0) + elseif (tt.ge.186.4 .and. tt.le.244.1) then + k3xco2 = 9.4 + 0.002253 * (tt-186.4) + elseif (tt.ge.244.1 .and. tt.le.300) then + k3xco2 = 9.53 + 0.02129 * (tt-244.1) + elseif (tt.ge.300 .and. tt.le.336.1) then + k3xco2 = 10.72 + 0.052632 * (tt-300) + elseif (tt.ge.336.1 .and. tt.le.397.0) then + k3xco2 = 12.62 + 0.0844 * (tt-336.1) + elseif (tt.ge.397.0 .and. tt.le.523.4) then + k3xco2 = 17.76 + 0.2615 * (tt-397.) + end if + k3xco2 = k3xco2 * 1.d-15 * rf3 + k3xaa = 0.82d0 * k3xco2 + k3xba = 0.18d0 * k3xco2 + + if (tt.le.163.) then + k3xco = 10.58 - 0.093 * (tt-140) + elseif (tt.ge.163. .and. tt.le.180.) then + k3xco = 8.44 - 0.05353 * (tt-163.) + elseif (tt.ge.180. .and. tt.le.196.) then + k3xco = 7.53 - 0.034375 * (tt-180.) + elseif (tt.ge.196. .and. tt.le.248.) then + k3xco = 6.98 - 0.0108 * (tt-196.) + elseif (tt.ge.248. .and. tt.le.301.) then + k3xco = 6.42 + 0.01415 * (tt-248.) + elseif (tt.ge.301. .and. tt.le.353.) then + k3xco = 7.17 + 0.02865 * (tt-301.) + end if + k3xac = k3xco * 1.d-15 * rf3 + k3xbc = 0.d0 + + elseif (iopt3.eq.2) then ! revision for the papers (feb 93) + + k3xco2 = 7.3d-14 * exp( -850.3/tt + 86523/tt**2.d0 ) + k3xco2 = k3xco2 * rf3 + k3xaa = 0.82d0 * k3xco2 + k3xba = 0.18d0 * k3xco2 + + k3xco = 1.7d-14 * exp( -448.3/tt + 53636/tt**2.d0 ) + k3xac = k3xco * rf3 + k3xbc = 0.d0 + + end if + + end if + + do i=1,nisot + k3aa(i) = k3xaa + k3ba(i) = k3xba + k3ab(i) = k3xab + k3bb(i) = k3xbb + k3ac(i) = k3xac + k3bc(i) = k3xbc + anu = nu(i,4)-nu(i,3) +! anu = nu(i,4)-nu(i,3)+70 + k3aap(i) = k3aa(i) * exp( -ee/tt * anu )/6.d0 + k3abp(i) = k3ab(i) * exp( -ee/tt * anu )/6.d0 + k3acp(i) = k3ac(i) * exp( -ee/tt * anu )/6.d0 + anu = nu(i,4)-nu(i,2) +! anu = nu(i,4)-nu(i,2)+40 + k3bap(i) = k3ba(i) * exp( -ee/tt * anu )/4.d0 + k3bbp(i) = k3bb(i) * exp( -ee/tt * anu )/4.d0 + k3bcp(i) = k3bc(i) * exp( -ee/tt * anu )/4.d0 + + k7a(i) = k7xa + k7b(i) = k7xb + k7ap(i) = k7a(i) * exp(dble( -ee/tt*(nu(i,4)-nu(i,3)) ))/6.d0 + k7bp(i) = k7b(i) * exp(dble( -ee/tt*(nu(i,4)-nu(i,2)) ))/4.d0 + end do + + +! the next ones correspond to vv2 in table 4, paper i +co2i(001) + co2 ---> co2i(020) + co2(010) k6 +! k6(i) i = 1,2,3,4 +! we need a new index for the inverse rates due to both fractions : +c k6a(i) i=2,3,4 co2i(001) + co2 ---> co2i(020) + co2(010) +c k6b(i) " co2i(001) + co2 ---> co2i(010) + co2(020) + + if (iopt6.eq.1) then + + if(tt.le.175.d0)then + k6x=8.6d-15 + elseif(tt.gt.175.0.and.tt.le.200.d0)then + k6x=8.6d-15+9.d-16*(175.d0-tt)/25.d0 + elseif(tt.gt.200.0.and.tt.le.225.d0)then + k6x=7.7d-15+5.d-16*(200.d0-tt)/25.d0 + elseif(tt.gt.225.0.and.tt.le.250.d0)then + k6x=7.20d-15+6.d-16*(tt-225.d0)/25.d0 + elseif(tt.gt.250.0.and.tt.le.275.d0)then + k6x=7.80d-15+1.d-15*(tt-250.d0)/25.d0 + elseif(tt.gt.275.0.and.tt.le.300.d0)then + k6x=8.80d-15+1.3d-15*(tt-275.d0)/25.d0 + elseif(tt.gt.300.0.and.tt.le.325.d0)then + k6x=10.1d-15+1.54d-15*(tt-300.d0)/25.d0 + elseif(tt.gt.325.0)then + k6x=11.6d-15 + end if + + elseif (iopt6.eq.2) then + + k6x = 3.6d-13 * exp( -1660/tt + 176948/tt**2.d0 ) + if (tt.lt.175) k6x = 8.8d-15 + + end if + + k6x1 = k6x * rf6 * frac6 + k6x2 = k6x * rf6 * (1.-frac6) + + k6 = k6x * rf6 + k6p = k6 / 8.d0 * exp(dble( -ee/tt * (nu(1,4)-nu(1,2)-nu(1,1)) )) + do i=2,nisot + k6a(i) = k6x1 + k6b(i) = k6x2 + anu = nu(i,4)-nu(i,2)-nu(1,1) + k6ap(i) = k6a(i) / 8.d0 * exp(dble( -ee*anu/tt )) + anu = nu(i,4)-nu(i,1)-nu(1,2) + k6bp(i) = k6b(i) / 8.d0 * exp(dble( -ee*anu/tt )) + end do + + +co2i(0v0) + co2i ---> co2i(0v-10) + co2i(010) +c k5 esta reaccion es desdenable frente a co2 como colisionante. +! k5=3.0d-15+6.0d-17*(tt-210.d0) +! k5=k5*rf5 +! k5p=k5/2.d0*exp(-ee*125.77/tt) + + +co2i(0v0) + m ---> co2i(0v-10) + m k19 (vt2,k5,k6 in table 3, paper +co2i(0v0) + o3p ---> co2i(0v-10) + o3p k20 (vt2,k7 in table 3, paper +c k19vm(i) m = a --- co2 v = a --- 3 i=1,2,3,4 +! b --- n2 b --- 2 +! c --- co c --- 1 +c k20v(i) v = a --- 3 i = 1,2,3,4 +! b --- 2 +! c --- 1 +! +! k20x=1.9d-8*exp(-76.75/(tt**(1.d0/3.d0))) ! taylor,74 reajusted +! k20x=2.32d-9*exp(-76.75/(tt**(1./3.)))+1.0d-14*sqrt(tt) ! k&j, 83 +! k20x = 1.43d-12*(tt/300.d0) ! shved et al, 90 + + if (iopt20.eq.1) then ! first version of pap1 + k20x=2.32d-9*exp(-76.75/(tt**(1./3.)))+3.5d-13*sqrt(tt) ! s&w, 91 + k20xb = k20x / 2.d0 * rf20 + k20xc = k20xb + k20xa = 3.d0/2.d0 * k20xb + elseif(iopt20.eq.2) then ! revision for the papers in feb 93 + k20x=3.d-12 ! minimum value of lopez-puertas et al., 92 + k20xc = k20x * rf20 + k20xb = 2.d0 * k20xc + k20xa = 3.d0/2.d0 * k20xb + elseif(iopt20.eq.3) then ! values from boug & roble '91 + k20x=1.d-12/sqrt(300.) * sqrt(tt) + k20xc = k20x * rf20 + k20xb = 2.d0 * k20xc + k20xa = 3.d0/2.d0 * k20xb + elseif(iopt20.eq.4) then ! values from boug & dick '88 case b + k20x=7.d-13 + k20xc = k20x * rf20 + k20xb = 2.d0 * k20xc + k20xa = 3.d0/2.d0 * k20xb + elseif(iopt20.eq.5) then ! values from s.bougher (oct-98) + k20x = 1.732d-13 * sqrt(tt) ! 1/sqrt(300) * sqrt(t) + k20xc = k20x * rf20 + k20xb = 2.d0 * k20xc + k20xa = 3.d0/2.d0 * k20xb + end if + + if (iopt19.eq.0) then + + k19xca = 4.64d-10 * exp(dble( - 74.75 / tt**(1.d0/3.d0) )) + k19xcb = 6.69d-10 * exp(dble( - 84.07 / tt**(1.d0/3.d0) )) + k19xcc = k19xcb + + if ( tt.le.250 ) then + k19xba = 181.25d0 + elseif ( tt.ge.310 ) then + k19xba = 200.d0 + 0.9d0 * ( tt - 310.d0 ) + else + k19xba = 181.25d0 + 0.3125d0 * ( tt - 250.d0 ) + end if + k19xba = k19xba * 1.03558d-19 * tt ! cm-1 s-1 + k19xbb = 1.24d-14 * ( tt / 273.3d0 )**2.d0 ! taine & lepoutre 1979 + k19xbc = k19xbb + + k19xaa = 3.d0/2.d0 * k19xba + k19xab = 3.d0/2.d0 * k19xbb + k19xac = 3.d0/2.d0 * k19xbc + + k19xaa = k19xaa * rf19 + k19xab = k19xab * rf19 + k19xac = k19xac * rf19 + k19xba = k19xba * rf19 + k19xbb = k19xbb * rf19 + k19xbc = k19xbc * rf19 + k19xca = k19xca * rf19 + k19xcb = k19xcb * rf19 + k19xcc = k19xcc * rf19 + + elseif (iopt19.ge.1) then + + if (iopt19.eq.1) then ! lunt et. al., 1985 (thesis values) + + if (tt.le.175.) then + k19xca = 4.d0 - 0.02d0 * (tt-140.d0) + k19xcb = 0.494d0 + 0.0076 * (tt-140.d0) + elseif (tt.ge.175. .and. tt.le.200.) then + k19xca = 3.3d0 - 0.02d0 * (tt-175.) + k19xcb = 0.76d0 + 0.0076d0 * (tt-175.d0) + elseif (tt.ge.200. .and. tt.le.225.) then + k19xca = 2.8d0 + 0.004d0 * (tt-200.d0) + k19xcb = 0.95d0 + 0.014d0 * (tt-200.d0) + elseif (tt.ge.225. .and. tt.le.250.) then + k19xca = 2.9d0 + 0.024d0 * (tt-225.d0) + k19xcb = 1.3d0 + 0.016d0 * (tt-225.d0) + elseif (tt.ge.250. .and. tt.le.275.) then + k19xca = 3.5d0 + 0.04d0 * (tt-250.d0) + k19xcb = 1.7d0 + 0.032d0 * (tt-250.d0) + elseif (tt.ge.275. .and. tt.le.295.) then + k19xca = 4.5d0 + 0.055d0 * (tt-275.d0) + k19xcb = 2.5d0 + 0.045d0 * (tt-275.d0) + elseif (tt.ge.295. .and. tt.le.320.) then + k19xca = 5.6d0 + 0.54d0 * (tt-295.d0) + k19xcb = 3.4d0 + 0.045d0 * (tt-295.d0) + end if + k19xca = k19xca * 1.d-15 * rf19 + k19xcb = k19xcb * 1.d-15 * rf19 + k19xcc = k19xcb + + elseif (iopt19.eq.2) then ! revision for the papers, feb 1993 + +! k19xca = 7.3d-14 * exp( -850.3d0/tt + 86523.d0/tt**2.d0 ) + k19xca = 4.2d-12 * exp( -2988.d0/tt + 303930.d0/tt**2.d0 ) + if (tt.le.175.) k19xca = 3.3d-15 + k19xcb = 2.1d-12 * exp( -2659.d0/tt + 223052.d0/tt**2.d0 ) + if (tt.le.175.) k19xcb = 7.6d-16 + k19xca = k19xca * rf19 + k19xcb = k19xcb * rf19 + k19xcc = k19xcb + + elseif (iopt19.eq.3) then ! values from dick'72 for k19xc + ! k19xcb is not modified + if (tt.le.158.) then + k19xca = 0.724d-15 + elseif (tt.le.190.) then + k19xca = 0.724d-15 + + @ (1.1d-15-0.724d-15) * (tt-158.) / (190.-158.) + elseif (tt.le.250.) then + k19xca = 1.1d-15 + + @ (3.45d-15-1.1d-15) * (tt-190.) / (250.-190.) + elseif (tt.gt.250.) then + k19xca = 3.45d-15 + end if + k19xcb = 2.1d-12 * exp( -2659.d0/tt + 223052.d0/tt**2.d0 ) + if (tt.le.175.) k19xcb = 7.6d-16 + k19xca = k19xca * rf19 + k19xcb = k19xcb * rf19 + k19xcc = k19xcb + + elseif (iopt19.eq.5) then + + k19xca = 5.2d-15 ! s.bougher, nov-98 + k19xcb = 7.6d-16 ! nuestro, de feb-93 + k19xcc = k19xcb + + k19xca = k19xca * rf19 + k19xcb = k19xcb * rf19 + + end if + + factor = 2.5d0 + k19xba = factor * k19xca + k19xbb = factor * k19xcb + k19xbc = factor * k19xcc + factor = 3.d0/2.d0 + k19xaa = factor * k19xba + k19xab = factor * k19xbb + k19xac = factor * k19xbc + + end if + + do i = 1, nisot + + k19aa(i) = k19xaa + k19ba(i) = k19xba + k19ca(i) = k19xca + k19ab(i) = k19xab + k19bb(i) = k19xbb + k19cb(i) = k19xcb + k19ac(i) = k19xac + k19bc(i) = k19xbc + k19cc(i) = k19xcc + anu = nu(i,3)-nu(i,2) + k19aap(i) = k19aa(i) * 6.d0/4.d0 * exp(dble( -ee*anu/tt)) + k19abp(i) = k19ab(i) * 6.d0/4.d0 * exp(dble( -ee*anu/tt)) + k19acp(i) = k19ac(i) * 6.d0/4.d0 * exp(dble( -ee*anu/tt)) + anu = nu(i,2)-nu(i,1) + k19bap(i) = k19ba(i) * 2.d0 * exp(dble( -ee*anu/tt)) + k19bbp(i) = k19bb(i) * 2.d0 * exp(dble( -ee*anu/tt)) + k19bcp(i) = k19bc(i) * 2.d0 * exp(dble( -ee*anu/tt)) + anu = nu(i,1) + k19cap(i) = k19ca(i) * 2.d0 * exp(dble( -ee*anu/tt)) + k19cbp(i) = k19cb(i) * 2.d0 * exp(dble( -ee*anu/tt)) + k19ccp(i) = k19cc(i) * 2.d0 * exp(dble( -ee*anu/tt)) + + k20a(i) = k20xa + k20b(i) = k20xb + k20c(i) = k20xc + k20ap(i) = k20a(i)*6.d0/4.d0 * + @ exp(dble( -ee/tt * (nu(i,3)-nu(i,2)) )) + k20bp(i) = k20b(i)*4.d0/2.d0 * + @ exp(dble( -ee/tt * (nu(i,2)-nu(i,1)) )) + k20cp(i) = k20c(i)*2.d0/1.d0 * + @ exp(dble( -ee/tt * nu(i,1) )) + end do + +! write(1,*) tt,k19cap(1),k19ac(1) + +! the next ones correspond to vv3 in table 4 (paper i) +co2i(0v0) + co2 ---> co2i(0v-10) + co2(010) k21 also see k33 +c k21v(i) v = a --- 3 i = 1,2,3,4 +! b --- 2 +! c --- 1 +! we need a new index for the 030i rates due to both fractions : +c k21a1 co2i(030) + co2 ---> co2i(020) + co2(010) +c k21a2 co2i(030) + co2 ---> co2i(010) + co2(020) +co2i(010) + co2j(000) ---> co2i(000) + co2j(010) kijk21c see pag.22-s +! k23k21c i=628,j=636 +! k24k21c i=628,j=627 +! k34k21c i=636,j=627 + + if (iopt21.eq.0) then + k21x = 1.2d-11 + k21xb = k21x + k21xa = 3.d0/2.d0 * k21x + k21xc = k21x ! esta ultima no se usa con 626 + elseif (iopt21.eq.1) then + k21x = 2.49d-11 ! orr & smith, 1987 + k21xb = k21x + k21xa = 3.d0/2.d0 * k21xb ! oscilador armonico + k21xc = k21xb / 2.d0 ! novedad mia + elseif (iopt21.eq.2) then + k21x = 100.d0*k19xca ! dickinson'76 (icarus) + k21xb = k21x + k21xa = 3.d0/2.d0 * k21xb ! oscilador armonico + k21xc = k21xb / 2.d0 ! novedad mia + end if + k21xa_626 = k21xa * rf21a !* 0.01d0 !* 10.d0 + k21xa = k21xa * rf21a !* 0.01d0 + k21xb = k21xb * rf21b + k21xc = k21xc * rf21c + + k21a = k21xa_626 + k21ap = k21a * 6.d0/8.d0 * + @ exp( dble( -ee/tt * (nu(1,3)-nu(1,2)-nu(1,1)) ) ) + do i = 2, nisot + k21a1(i) = k21xa * frac21 + k21a2(i) = k21xa * (1.d0-frac21) + k21a1p(i) = k21a1(i) * 6.d0/8.d0 * + @ exp(dble( -ee/tt* (nu(i,3)-nu(i,2)-nu(1,1)) )) + k21a2p(i) = k21a2(i) * 6.d0/8.d0 * + @ exp(dble( -ee/tt* (nu(i,3)-nu(i,1)-nu(1,2)) )) + end do + + + do i = 1, nisot + k21b(i) = k21xb + k21c(i) = k21xc + k21bp(i) = k21b(i) * + @ exp(dble( -ee/tt* (nu(i,2)-nu(i,1)-nu(1,1)) )) + k21cp(i) = k21c(i) * + @ exp(dble( -ee/tt * (nu(i,1)-nu(1,1)) )) + end do + + k23k21c = k21xc + k24k21c = k21xc + k34k21c = k21xc + k23k21cp = k23k21c*2.d0/2.d0 * + @ exp(dble( -ee/tt* (nu(2,1)-nu(3,1)) )) + k24k21cp = k24k21c*2.d0/2.d0 * + @ exp(dble( -ee/tt* (nu(2,1)-nu(4,1)) )) + k34k21cp = k34k21c*2.d0/2.d0 * + @ exp(dble( -ee/tt* (nu(3,1)-nu(4,1)) )) + +! these are also vv3 in table 4, paper i +c k31 & k32 + + k31 = k21x * rf31 ! we're suposing thar the rate for the deactivation + ! v-v from high combinational levels is the same + k32 = k21x * rf32 ! that the one for : (020) --> (010) + (010) + +c o2(***) + co2i ---> co2(***) + co2i(***) k33 +c k33a1 : co2(001) + co2i ---> co2(020) + co2i(010) (vv2, table 4, +! a2 : co2(001) + co2i ---> co2(010) + co2i(020) " +! b1 : co2(030) + co2i ---> co2(020) + co2i(010) (vv3, table 4, +! b2 : co2(030) + co2i ---> co2(010) + co2i(020) " +! c : co2(020) + co2i ---> co2(010) + co2i(010) " +! we have to add an index to the inverse rates, depending on the isotope + + k33c = k21x * rf33bc + k33b1 = 3.d0/3.d0 * k33c * frac33 + k33b2 = 3.d0/3.d0 * k33c * (1.d0-frac33) + k33a1 = k6x * rf33a * frac33 + k33a2 = k6x * rf33a * (1.d0-frac33) + + do i=2,nisot + k33a1p(i)=k33a1* + @ 1.d0/8.d0*exp(dble( -ee/tt* (nu(1,4)-nu(1,2)-nu(i,1)) )) + k33a2p(i)=k33a2* + @ 1.d0/8.d0*exp(dble( -ee/tt* (nu(1,4)-nu(1,1)-nu(i,2)) )) + k33b1p(i)=k33b1* + @ 6.d0/8.d0*exp(dble( -ee/tt* (nu(1,3)-nu(1,2)-nu(i,1)) )) + k33b2p(i)=k33b2* + @ 6.d0/8.d0*exp(dble( -ee/tt* (nu(1,4)-nu(1,1)-nu(i,2)) )) + k33cp(i) =k33c * exp(dble( -ee/tt * (nu(1,2)-nu(1,1)-nu(i,1)) )) + end do + +! here they are the vt3 in table 3, paper i +co2(2.7um) + m ---> co2(2.7um) + m k27 +c k27a : n8 + m ---> n6 + m +! b : n7 + m ---> n6 + m +! c : n8 + m ---> n7 + m + + if (iopt27.eq.0) then + k27a = 3.d-11 !between fermi levels + k27b = 3.d-13 !between side levels + k27c = 2.d0 * k27b !between side levels + elseif (iopt27.ge.1) then ! orr & smith, 1987 + k27a = 1.55d-12 + k27c = 4.97d-12 + k27b = k27c + end if + k27a = k27a * rf27f + k27b = k27b * rf27s + k27c = k27c * rf27s + + k27ap = k27a * exp(dble( -ee/tt * (nu(1,8)-nu(1,6)) )) + k27bp = k27b * exp(dble( -ee/tt * (nu(1,7)-nu(1,6)) )) + k27cp = k27c * exp(dble( -ee/tt * (nu(1,8)-nu(1,7)) )) + + +! the next two are not used in the model: + +c k28 : n* + n2 ---> n*low + n2(1) +! k28v v = a --- n8 +! b --- n7 +! c --- n6 +! k28a = 5.d-13 * sqrt(300.d0/tt) * rf28 ! = k1 +! k28b = k28a +! k28c = k28a +! k28ap = k28a * exp( -ee/tt * (nu(1,8)-1388.1847-nun2) ) +! k28bp = k28b * exp( -ee/tt * (nu(1,7)-1335.1317-nun2) ) +! k28cp = k28c * exp( -ee/tt * (nu(1,6)-1285.4087-nun2) ) + +c k29 : n* + co ---> n*low + co(1) +! k29v v = a --- n8 +! b --- n7 +! c --- n6 + +c k29a = ?????????? * rf29 +c k29b = k29a +c k29c = k29a + +c k29ap = k29a * exp( -ee/tt * (nu(1,8)-1388.1847-nuco) ) +c k29bp = k29b * exp( -ee/tt * (nu(1,7)-1335.1317-nuco) ) +c k29cp = k29c * exp( -ee/tt * (nu(1,6)-1285.4087-nuco) ) + + +! these are also vv1 processes in table 4, paper i +c k26 : +! 1. deactivation of the 626 isotope: +! reaction: n* + co2i ---> n*low + co2i(001) ; i=1-4 +! nomenclature: k26v ; v=a,b,c,d for n8,n7,n6,n5 respectively +! inverse rates: k26vp(i) ; i=1-4 +! 2. deactivation of the minor isotopes: +! reaction: n*_i + co2j ---> n*_i_low + (001)_j ; i=2-4 ; j=1-4 +! nomenclature: k26vij ; v=a,c,d for n8,n6,n5 respectively +! inverse rates: k26vijp +! 3. notes: +! a * it is clear that : k26vij=/=k26vjip, +! b * at the moment we do not include inverse rates for the case 2., o +! the deactivation of the main isotope (pg. 32b, sn1). +! c * not 0221 level for minor isotopes is considered. +! d * only a value is known for these rates, so all of the deactivatio +! the same, but not the inverse rates. +! e * although all the direct deactivation constants have the same val +! it is useful to distinguish between them with the present nam + + k26a = 6.8d-12 * sqrt(tt) * rf26 ! = k2 + k26b = k26a + k26c = k26a + if (iopt26.eq.0 .or. iopt26.eq.2) then + k26d = k26a + elseif( iopt26.eq.1) then + k26d = 1.15d-10 * rf26 + end if + + do i=1,4 + k26ap(i) = k26a * + @ exp(dble( -ee/tt * (nu(1,8)-nu12_1000-nu(i,4)) )) + k26bp(i) = k26b * + @ exp(dble( -ee/tt * (nu(1,7)- nu(1,2) -nu(i,4)) )) + k26cp(i) = k26c * + @ exp(dble( -ee/tt * (nu(1,6)-nu12_0200-nu(i,4)) )) + k26dp(i) = k26d * + @ exp(dble( -ee/tt * (nu(1,5)- nu(1,1) -nu(i,4)) )) + end do + + k26a21 = k26a + k26c21 = k26c + k26d21 = k26d + k26a22 = k26a + k26c22 = k26c + k26d22 = k26d + k26a23 = k26a + k26c23 = k26c + k26d23 = k26d + k26a24 = k26a + k26c24 = k26c + k26d24 = k26d + + k26a31 = k26a + k26c31 = k26c + k26d31 = k26d + k26a32 = k26a + k26c32 = k26c + k26d32 = k26d + k26a33 = k26a + k26c33 = k26c + k26d33 = k26d + k26a34 = k26a + k26c34 = k26c + k26d34 = k26d + + k26a41 = k26a + k26c41 = k26c + k26d41 = k26d + k26a42 = k26a + k26c42 = k26c + k26d42 = k26d + k26a43 = k26a + k26c43 = k26c + k26d43 = k26d + k26a44 = k26a + k26c44 = k26c + k26d44 = k26d + +!! some examples of inverse rates, although not used at the moment +! k26a32p = k26a32 * exp( -ee* (nu(3,8)-nu32_1000-nu(2,4)) / tt )*1./1. +! k26c32p = k26c32 * exp( -ee* (nu(3,6)-nu32_0200-nu(2,4)) / tt )*1./1. +! k26d32p = k26d32 * exp( -ee* (nu(3,5)- nu(3,1) -nu(2,4)) / tt )*2./2. +! +! k26a43 = k26a34 * exp( -ee* (nu(3,8)-nu32_1000-nu(4,4)) / tt )*1./1. +! k26c43 = k26c34 * exp( -ee* (nu(3,6)-nu32_0200-nu(4,4)) / tt )*1./1. +! k26d43 = k26d34 * exp( -ee* (nu(3,5)- nu(3,1) -nu(4,4)) / tt )*2./2. +! +! k26a24p = k26a24 * exp( -ee* (nu(2,8)-nu22_1000-nu(4,4)) / tt )*1./1. +! k26c24p = k26c24 * exp( -ee* (nu(2,6)-nu22_0200-nu(4,4)) / tt )*1./1. +! k26d24p = k26d24 * exp( -ee* (nu(2,5)- nu(2,1) -nu(4,4)) / tt )*2./2. + + +! this is taken as vv4 in table 4, paper i (in the inverse direction) +c k41 : co(v) + co2 ---> co(v-1) + co2(001) + de +! k41_v v=1,2,3,4 +! +! de = -205.9 cm-1 when v=1 +! de = -232.9 cm-1 when v=2 +! de = -258.6 cm-1 when v=3 +! de = -285.0 cm-1 when v=4 + + k41p_taylor = 1.56d-11 * exp( -30.12/tt**0.333333 ) ! [ s-1 cm+3 ] + k41p_shved = 7.5d7/sqrt(tt) ! [ s-1 atm-1 ] + k41p_shved = k41p_shved * 1.38d-16/1013250. * tt ! [ s-1 cm+3 ] + k41p_starr_hannock = 6.27d3 ! [ s-1 torr-1 ] + + if (iopt41.eq.1) then + k41p_1 = k41p_starr_hannock * + @ 760.*1.38d-16/1013250. * tt ! [ s-1 cm+3 ] + elseif (iopt41.eq.2) then + k41p_1 = 1.6d-12 * exp( -1169/tt + 77601/tt**2.d0 ) + end if + k41p_1 = k41p_1 * rf41 + k41_1 = k41p_1 * exp(dble( -ee * 205.9/tt )) + k41_2 = k41_1 + k41p_2 = k41_2 * exp(dble( -ee * (-232.9)/tt )) + k41_3 = k41_1 + k41p_3 = k41_3 * exp(dble( -ee * (-258.6)/tt )) + k41_4 = k41_1 + k41p_4 = k41_4 * exp(dble( -ee * (-285.0)/tt )) + + !k41p_1 = k41p_1 * 1.d-6 + !k41p_2 = k41p_2 * 1.d-6 + +c k41iso : 63(v) + co2 ---> 63(v-1) + co2(001) + de +! k41iso_v v=1,2,3 +! de = -253 cm-1 when v=1 +! de = -278 cm-1 when v=2 +! de = -303 cm-1 when v=3 + + k41iso_1 = k41_1 + k41iso_1p = k41iso_1 * exp(dble( -ee * (-253.)/tt )) + k41iso_2 = k41iso_1 + k41iso_2p = k41iso_2 * exp(dble( -ee * (-278.)/tt )) + k41iso_3 = k41iso_1 + k41iso_3p = k41iso_3 * exp(dble( -ee * (-303.)/tt )) + + + +c k42 : co(v) + co ---> co(v-1) + co(1) + de=-26.481 si v=2 K42 +! -52.8940 si v=3 k42b +! -79.2402 si v=4 k42c +! tomado de stepanova & shved (ellos de powell, 1975), ver pg .. l5 + ! solo para v=2 : + + k42 = 2.89d-10 * (1./sqrt(tt) + 67.4/tt**1.5) * + @ exp(dble(24.78/tt)) + k42 = k42 * rf42 + k42b = k42 + k42c = k42 + k42p = k42 * exp(dble( -ee * (-26.481)/tt )) + k42bp = k42b * exp(dble( -ee * (-52.894)/tt )) + k42cp = k42c * exp(dble( -ee * (-79.24)/tt )) + +c k42iso : 63(v) + 63 ---> 63(v-1) + 63(1) + de=-25.31 si v=2 K42iso +! -50.57 si v=3 k42isob +! tomado de stepanova & shved (ellos de powell, 1975), ver pg .. l5 + ! solo para v=2 : + + k42iso = k42 + k42isop = k42iso * exp(dble( -ee * (-25.31)/tt )) + k42isob = k42 + k42isobp = k42isob * exp(dble( -ee * (-50.57)/tt )) + + +c k43 : co(v) + o3p ---> co(v-1) + o3p + de=2143 +! tomado de lewittes et. al, 1978 para v=1 + + if (iopt43.eq.1) then + tt1 = tt - 300. + k43 = 2.85d-14 * exp( dble( 9.5e-3*tt1 + 1.11e-4*tt1**2. ) ) + elseif (iopt43.eq.2) then + k43 = 1.4d-5 * exp( -10957.d0 / tt + 1.486d6 / tt**2.d0 ) + if ( tt.lt.265.0 ) k43 = 2.3d-14 + end if + k43 = k43 * rf43 + k43p = k43 * exp( -ee * dble(2143.3 / tt) ) + +c k43iso : co63(v) + o3p ---> co63(v-1) + o3p + de=2096 +! Por similitud con el anterior + + k43iso = k43 + k43isop = k43iso * exp( -ee * dble(2096. / tt) ) + + +c k44 : co62(v) + co63 ---> co62(v-1) + co63(1) + de +! basado en Lopez-Valverde et al para el caso v=1, solo usamos este +! k44x x = a --- v=1 de= 147.33 +! b --- v=2 de= 20.7241 +! c --- v=3 de= -5.7 +! d --- v=4 de= -32.0361 + + k44a = 2.0d-12 * rf44 ! Solo vamos a usar este, no los b,c,d + k44b = k44a + k44c = k44a + k44d = k44a + + de = 147.33 + k44ap = k44a * exp(dble( -ee * de/tt )) + de = 20.7241 + k44bp = k44b * exp(dble( -ee * de/tt )) + de = -5.7 + k44cp = k44c * exp(dble( -ee * de/tt )) + de = -32.0361 + k44dp = k44d * exp(dble( -ee * de/tt )) + + +co2(hcl) + co2 --> co2 + co2 + de(hcl) +! este rate tambien lo usamos para los high combination levels (para tra +! al lte. cualquier valor vale, supongo. es k_vthcl + + k_vthcl = 3.3d-15 ! similar al valor pequenho del vt2 + k_vthcl = k_vthcl * rf_hcl + + return + end Index: trunk/LMDZ.MARS/libf/phymars/nlte_matrix.h =================================================================== --- trunk/LMDZ.MARS/libf/phymars/nlte_matrix.h (revision 496) +++ (revision ) @@ -1,65 +1,0 @@ -c**************************************************************************** -c matrices.cmn -c -c common that connects all cz* with fot*, with matrix for groups -c -c @ 0-3-97 cristina -c JAN 98 MALV Version para mz1d -c**************************************************************************** - -c curtis matrix de cza: - common/curtis_matrixes_15um/ c110,c121, c210, - @ c310, c410, - @ vc110,vc121, vc210, - @ vc310, vc410 - real*8 c110(nl,nl), c121(nl,nl) - real*8 c210(nl,nl) - real*8 c310(nl,nl) - real*8 c410(nl,nl) - real*8 vc110(nl), vc121(nl) - real*8 vc210(nl), vc310(nl), vc410(nl) - - common/curtis_matr_up_15um/ - @ cup110,cup121 - real*8 cup110(nl,nl), cup121(nl,nl) - - common/curtis_matr_dw_15um/ - @ cdw110,cdw121 - real*8 cdw110(nl,nl), cdw121(nl,nl) - - common/curtis_matr_taugr_15um/ - @ taugr110,taugr121 - real*8 taugr110(nl), taugr121(nl) - -! for the new flux formulation: -! -! - common/tauinf_15um/ tauinf121, - @ tauinf210,tauinf310,tauinf410,tauinf110 - real*8 tauinf121(nl) - real*8 tauinf210(nl), tauinf310(nl), tauinf410(nl) - real*8 tauinf110(nl) - -! for the cool-to-space formulation: -! - common/taustar_15um/ taustar11, taustar21, taustar31, - @ taustar41, taustar12 - real*8 taustar11(nl), taustar21(nl), taustar31(nl) - real*8 taustar41(nl), taustar12(nl) - - common/tauii_15um/ tauii110, tauii210, tauii310, - @ tauii410, tauii121 - real*8 tauii110(nl), tauii210(nl), tauii310(nl) - real*8 tauii410(nl), tauii121(nl) - -! for the name of the C.Matrix files -! - common/cm_names/ fileroot - character fileroot*3 - -c**************************************************************************** - - - - - Index: trunk/LMDZ.MARS/libf/phymars/nlte_paramdef.h =================================================================== --- trunk/LMDZ.MARS/libf/phymars/nlte_paramdef.h (revision 498) +++ trunk/LMDZ.MARS/libf/phymars/nlte_paramdef.h (revision 498) @@ -0,0 +1,166 @@ +c**************************************************************************** +c +c Merging of different parameters definitions for new NLTE 15um param +c +c jan 2012 fgg+malv +c**************************************************************************** +c *** Old nltedefs.h *** +! NLTE grid parameters: + + integer nl ! actual # alt in NLTE module + parameter ( nl=20 ) + + integer nl2 ! = nl-2, needed for matrix inversion (mmh2) + parameter ( nl2=nl-2 ) + + integer nzy + parameter ( nzy = (nl-1)*4 + 1 ) ! Fine grid for mztud.f + + +! Other NLTE parameters: + integer nisot ! number of isotopes considered + integer nb ! number of bands included + parameter ( nisot=4, nb=41 ) + + integer nhist ! # of temps in histogr. + parameter ( nhist = 36 ) ! (get it from histograms!) + + integer nbox_max + parameter ( nbox_max = 70 ) ! max.# boxes in histogram + + +c *** Old tcr15um.h *** + integer irw_mztf,imu,ioverlap,nw,itt_cza,icls_mztf,nan +c + parameter (irw_mztf = 2) + parameter (imu = 1) + parameter (ioverlap = 0) + parameter (nw = 3) + parameter (itt_cza = 13) + parameter (icls_mztf = 5) + parameter (nan = 0) +c +c + integer iopt3, iopt19,iopt20, iopt21,iopt27,iopt26 +c + parameter (iopt3 = 1) + parameter (iopt19 = 2) + parameter (iopt20 = 2) + parameter (iopt21 = 1) + parameter (iopt27 = 1) + parameter (iopt26 = 2) +c +c + integer iopt41,iopt43, iopt6 +c + parameter (iopt6 = 2) + parameter (iopt41 = 2) + parameter (iopt43 = 2) +c +c + real tsurf_excess,Pbottom_atm,Ptop_atm +c + parameter (tsurf_excess = 0.) + parameter (Pbottom_atm = 2.e-5) + parameter (Ptop_atm = 5.e-12) +c +c + real*8 rf1,rf2desac,rf2iso,rf3,rf6 +c + parameter (rf1 = 1.d0) + parameter (rf2desac = 1.d0) + parameter (rf2iso = 1.d0) + parameter (rf3 = 1.d0) + parameter (rf6 = 1.d0) +c +c + real*8 rf7,rf19,rf20,rf21a,rf21b,rf21c +c + parameter (rf7 = 1.d0) + parameter (rf19 = 1.d0) + parameter (rf20 = 1.d0) + parameter (rf21a = 1.d0) + parameter (rf21b = 1.d0) + parameter (rf21c = 1.d0) +c +c + real*8 rf26,rf27f,rf27s,rf28,rf31,rf32,rf33a,rf33bc +c + parameter (rf26 = 1.d0) + parameter (rf27f = 1.d0) + parameter (rf27s = 1.d0) + parameter (rf28 = 1.d0) + parameter (rf31 = 1.d0) + parameter (rf32 = 1.d0) + parameter (rf33a = 1.d0) + parameter (rf33bc = 1.d0) +c +c + real*8 rf41,rf42,rf43,rf_hcl,rf44 +c + parameter (rf41 = 1.d0) + parameter (rf42 = 1.d0) + parameter (rf43 = 1.d0) + parameter (rf_hcl = 1.d0) + parameter (rf44 = 1.d0) +c +c + real*8 frac6,frac21,frac33 +c + parameter (frac6 = 1.d0) + parameter (frac21 = 1.d0) + parameter (frac33 = 1.d0) + + +c *** Old nlte_data.h and bloque.F *** + real*8 vlight, ee, hplanck, gamma + parameter (vlight = 2.9979245e10) + parameter (ee = 1.43876866) + parameter (hplanck = 6.6260755e-27) + parameter (gamma = 1.191043934e-5) + + real imr(nisot), imrco + parameter (imrco = 0.9865) + data imr / 0.987, 0.00408, 0.0112, 0.000742 / + + integer indexisot(nisot) + data indexisot/26,28,36,27/ + + real deltanuco + parameter (deltanuco = 306.) + + real nuco_10 + parameter (nuco_10 = 2143.2716) + + real nun2,nu12_0200,nu12_1000,nu22_0200,nu22_1000 + parameter (nun2 = 2331.0) + parameter (nu12_0200 = 1285.4087) + parameter (nu12_1000 = 1388.1847) + parameter (nu22_0200 = 1259.4257) + parameter (nu22_1000 = 1365.8439) + + real nu32_0200,nu32_1000, nu42_0200,nu42_1000 + parameter (nu32_0200 = 1265.8282) + parameter (nu32_1000 = 1370.0626) + parameter (nu42_0200 = 1272.2866) + parameter (nu42_1000 = 1376.0275) + + real nu(nisot,8) + data nu(1,1),nu(1,2),nu(1,3),nu(1,4) + @ /667.3801, 1335.1317, 2003.2463, 2349.1433/ + data nu(1,5),nu(1,6),nu(1,7),nu(1,8) + @ /3004.0112, 3612.8417, 3659.2728, 3714.7828/ + data nu(2,1),nu(2,2),nu(2,3),nu(2,4) + @ /662.3734, 1325.1410, 1988.3280, 2332.1128/ + data nu(2,5),nu(2,6),nu(2,7),nu(2,8) + @ /2982.1115, 3571.1404, 3632.5240, 3675.1332/ + data nu(3,1),nu(3,2),nu(3,3),nu(3,4) + @ /648.4784, 1297.2640, 1946.3507, 2283.4876/ + data nu(3,5),nu(3,6),nu(3,7),nu(3,8) + @ /2920.2387, 3527.7380, 3557.3145, 3632.9112/ + data nu(4,1),nu(4,2),nu(4,3),nu(4,4) + @ /664.7289, 1329.8430, 1995.3520, 2340.0136/ + data nu(4,5),nu(4,6),nu(4,7),nu(4,8) + @ /2992.3100, 3591.2510, 3644.9900, 3693.3460/ + + Index: trunk/LMDZ.MARS/libf/phymars/nlte_rates.h =================================================================== --- trunk/LMDZ.MARS/libf/phymars/nlte_rates.h (revision 496) +++ (revision ) @@ -1,80 +1,0 @@ - common/rates_vt/ k7a(4),k7b(4), k7ap(4),k7bp(4), - @ k3aa(4),k3ab(4),k3ac(4), k3aap(4),k3abp(4),k3acp(4), - @ k3ba(4),k3bb(4),k3bc(4), k3bap(4),k3bbp(4),k3bcp(4), - @ k19aa(4),k19ab(4),k19ac(4), k19aap(4),k19abp(4),k19acp(4), - @ k19ba(4),k19bb(4),k19bc(4), k19bap(4),k19bbp(4),k19bcp(4), - @ k19ca(4),k19cb(4),k19cc(4), k19cap(4),k19cbp(4),k19ccp(4), - @ k20a(4),k20b(4),k20c(4), k20ap(4),k20bp(4),k20cp(4), - @ k27a,k27b,k27c, k27ap,k27bp,k27cp - - real*8 k7a,k7b, k7ap,k7bp - real*8 k3aa,k3ab,k3ac, k3aap,k3abp,k3acp - real*8 k3ba,k3bb,k3bc, k3bap,k3bbp,k3bcp - real*8 k19aa,k19ab,k19ac, k19aap,k19abp,k19acp - real*8 k19ba,k19bb,k19bc, k19bap,k19bbp,k19bcp - real*8 k19ca,k19cb,k19cc, k19cap,k19cbp,k19ccp - real*8 k20a,k20b,k20c, k20ap,k20bp,k20cp - real*8 k27a,k27b,k27c, k27ap,k27bp,k27cp - - common/rates_vv/ k1(4),k1p(4), - @ k2a,k2b, k2x,k2y,k2z, k2xp,k2yp,k2zp, - @ k6,k6p, k6a(2:4),k6b(2:4), k6ap(2:4),k6bp(2:4), - @ k21a,k21ap, k21a1(2:4),k21a2(2:4), k21a1p(2:4),k21a2p(2:4), - @ k21b(4),k21c(4), k21bp(4),k21cp(4), - @ k31,k32, - @ k33a1,k33a2,k33b1,k33b2,k33c, - @ k33a1p(2:4),k33a2p(2:4),k33b1p(2:4),k33b2p(2:4),k33cp(2:4), - @ k28a,k28b,k28c, k28ap,k28bp,k28cp, - @ k26a,k26b,k26c,k26d, k26ap(4),k26bp(4),k26cp(4),k26dp(4), - @ k41p_taylor, k41p_shved, k41p_starr_hannock, - @ k41_1,k41p_1, k41_2,k41p_2, k42,k42p - - real*8 k1,k1p - real*8 k2a,k2b, k2x,k2y,k2z, k2xp,k2yp,k2zp - real*8 k6,k6p, k6a,k6b, k6ap,k6bp - real*8 k21a,k21ap, k21a1,k21a2, k21a1p,k21a2p - real*8 k21b,k21c, k21bp,k21cp - real*8 k31,k32 - real*8 k33a1,k33a2,k33b1,k33b2,k33c - real*8 k33a1p,k33a2p,k33b1p,k33b2p,k33cp - real*8 k28a,k28b,k28c, k28ap,k28bp,k28cp - real*8 k26a,k26b,k26c,k26d, k26ap,k26bp,k26cp,k26dp - real*8 k41p_taylor, k41p_shved, k41p_starr_hannock - real*8 k41_1,k41p_1, k41_2,k41p_2, k42,k42p - - - common/rates_k26isot/ k26a21,k26c21,k26d21, - @ k26a22,k26c22,k26d22, k26a23,k26c23,k26d23, - @ k26a24,k26c24,k26d24, - @ k26a32,k26c32,k26d32, k26a33,k26c33,k26d33, - @ k26a31,k26c31,k26d31, - @ k26a34,k26c34,k26d34, k26a42,k26c42,k26d42, - @ k26a41,k26c41,k26d41, - @ k26a43,k26c43,k26d43, k26a44,k26c44,k26d44 - - real*8 k26a21,k26c21,k26d21, - @ k26a22,k26c22,k26d22, k26a23,k26c23,k26d23, - @ k26a24,k26c24,k26d24, - @ k26a32,k26c32,k26d32, k26a33,k26c33,k26d33, - @ k26a31,k26c31,k26d31, - @ k26a34,k26c34,k26d34, k26a42,k26c42,k26d42, - @ k26a41,k26c41,k26d41, - @ k26a43,k26c43,k26d43, k26a44,k26c44,k26d44 - - - common/rates_last/ k23k21c, k24k21c, k34k21c, - @ k23k21cp, k24k21cp, k34k21cp, k43,k43p, k_vthcl - - real*8 k23k21c,k24k21c,k34k21c, k23k21cp,k24k21cp,k34k21cp - real*8 k43,k43p, k_vthcl - - common/rates_V09/ k41_3,k41p_3, k41_4,k41p_4, k41iso_1,k41iso_1p, - @ k41iso_2,k41iso_2p, k41iso_3,k41iso_3p, - @ k42b, k42c, k42bp, k42cp, k43iso,k43isop, - @ k44a,k44b,k44c,k44d, k44ap,k44bp,k44cp,k44dp, - @ k42iso,k42isop, k42isob,k42isobp - real*8 k41_3,k41p_3, k41_4,k41p_4, k41iso_1,k41iso_1p - real*8 k41iso_2,k41iso_2p, k41iso_3,k41iso_3p - real*8 k42b, k42c, k42bp, k42cp, k43iso,k43isop - real*8 k44a,k44b,k44c,k44d, k44ap,k44bp,k44cp,k44dp - real*8 k42iso,k42isop, k42isob,k42isobp Index: trunk/LMDZ.MARS/libf/phymars/nlte_results.h =================================================================== --- trunk/LMDZ.MARS/libf/phymars/nlte_results.h (revision 496) +++ (revision ) @@ -1,62 +1,0 @@ -c**************************************************************************** -c -c nlte_results.cmn -c -c JAN 98 MALV Based on mztv1.cmn, mztv4_abc.cmn -c**************************************************************************** - -c Next common: parameter that decides which level populations -c are already known and therefore are read and used in this program. - common/input_avilable_from/ input_cza, input_czb, input_czc, - @ input_czco - integer input_cza, input_czb, input_czc, input_czco - -c temperatura vibracional de entrada: - common/temp626/ v626t1,v626t2,v626t3,v626t4, - @ v626t5,v626t6,v626t7,v626t8 - common/temp628/ v628t1, v628t2, v628t3, v628t4 - common/temp636/ v636t1, v636t2, v636t3, v636t4 - common/temp627/ v627t1, v627t2, v627t3, v627t4 - common/tempco/ vcot1, vcot2, vcot3, vcot4, v63t1,v63t2,v63t3 - real*8 v626t4(nl), v628t4(nl), v636t4(nl), v627t4(nl) - real*8 v626t1(nl), v626t2(nl), v626t3(nl) - real*8 v626t5(nl), v626t6(nl), v626t7(nl), v626t8(nl) - real*8 v628t1(nl), v628t2(nl), v628t3(nl) - real*8 v636t1(nl), v636t2(nl), v636t3(nl) - real*8 v627t1(nl), v627t2(nl), v627t3(nl) - real*8 vcot1(nl), vcot2(nl), vcot3(nl), vcot4(nl) - real*8 v63t1(nl), v63t2(nl), v63t3(nl) - -c output de cza.for - common /tv15um/ vt11, vt12, vt13, - @ vt21, vt22, vt23, - @ vt31, vt32, vt33, - @ vt41, vt42, vt43 - real*8 vt11(nl), vt12(nl), vt13(nl), - @ vt21(nl), vt22(nl), vt23(nl), - @ vt31(nl), vt32(nl), vt33(nl), - @ vt41(nl), vt42(nl), vt43(nl) - - common /hr15um/ hr110,hr210,hr310,hr410, - @ hr121,hr221,hr321,hr421, - @ hr132,hr232,hr332,hr432 - real*8 hr110(nl),hr121(nl),hr132(nl), - @ hr210(nl),hr310(nl),hr410(nl), - @ hr221(nl),hr232(nl),hr321(nl), - @ hr332(nl),hr421(nl),hr432(nl) - - common/sf15um/ el11,el12,el13, el21,el22,el23, - @ el31,el32,el33, el41,el42,el43 - real*8 el11(nl), el12(nl), el13(nl) - real*8 el21(nl), el22(nl), el23(nl) - real*8 el31(nl), el32(nl), el33(nl) - real*8 el41(nl), el42(nl), el43(nl) - - common/sl15um/ sl110,sl121,sl132, sl210,sl221,sl232, - @ sl310,sl321,sl332, sl410,sl421,sl432 - real*8 sl110(nl), sl121(nl), sl132(nl) - real*8 sl210(nl), sl221(nl), sl232(nl) - real*8 sl310(nl), sl321(nl), sl332(nl) - real*8 sl410(nl), sl421(nl), sl432(nl) - - Index: trunk/LMDZ.MARS/libf/phymars/nlte_tcool.F =================================================================== --- trunk/LMDZ.MARS/libf/phymars/nlte_tcool.F (revision 498) +++ trunk/LMDZ.MARS/libf/phymars/nlte_tcool.F (revision 498) @@ -0,0 +1,1257 @@ +c*********************************************************************** + + subroutine NLTEdlvr09_TCOOL (ngridgcm,n_gcm, + @ p_gcm, t_gcm, z_gcm, + @ co2vmr_gcm, n2vmr_gcm, covmr_gcm, o3pvmr_gcm, + @ q15umco2_gcm ) + +c jul 2011 malv+fgg +c*********************************************************************** + + implicit none + + include "dimensions.h" + include "dimphys.h" + include 'nlte_paramdef.h' + include 'nlte_commons.h' + include "chimiedata.h" + include "conc.h" + +c Arguments + integer n_gcm,ngridgcm + real p_gcm(ngridgcm,n_gcm), t_gcm(ngridgcm,n_gcm) + real co2vmr_gcm(ngridgcm,n_gcm), n2vmr_gcm(ngridgcm,n_gcm) + real covmr_gcm(ngridgcm,n_gcm), o3pvmr_gcm(ngridgcm,n_gcm) + real q15umco2_gcm(ngridgcm,n_gcm) + real z_gcm(ngridgcm,n_gcm) + +c local variables and constants + integer iz, i, j, k, l, ig,istyle + + real*8 q15umco2_nl(nl) + real*8 zld(nl), zgcmd(n_gcm) + real*8 auxdgcm(n_gcm) + + + real p_ig(n_gcm),z_ig(n_gcm) + real t_ig(n_gcm) + real co2_ig(n_gcm),n2_ig(n_gcm),co_ig(n_gcm),o3p_ig(n_gcm) + real mmean_ig(n_gcm),cpnew_ig(n_gcm) + + +c********************************************************************** + + do ig=1,ngridgcm + do l=1,n_gcm + p_ig(l)=p_gcm(ig,l) + t_ig(l)=t_gcm(ig,l) + co2_ig(l)=co2vmr_gcm(ig,l) + n2_ig(l)=n2vmr_gcm(ig,l) + o3p_ig(l)=o3pvmr_gcm(ig,l) + co_ig(l)=covmr_gcm(ig,l) + z_ig(l)=z_gcm(ig,l)/1000. + mmean_ig(l)=mmean(ig,l) + cpnew_ig(l)=cpnew(ig,l) + enddo + + call NLTEdlvr09_ZGRID (n_gcm, + @ p_ig, t_ig, z_ig, + @ co2_ig,n2_ig,co_ig, + $ o3p_ig , mmean_ig, cpnew_ig) + +c And sets zero to all Curtis Matrixes and Escape Transmissions + call leetvt + call zero3m (c110,cup110,cdw110, nl) + call zero2v (taugr110,vc110, nl) + if (itt_cza.eq.24) then + call mzescape ( ig,taustar11,tauinf110,tauii110, + @ 1, 1,irw_mztf,imu ) + istyle=2 + call mzescape_normaliz ( taustar11, istyle ) + else + call mztud (ig, c110,cup110,cdw110, vc110,taugr110, + @ 1, 1, irw_mztf, imu, 0,0,0 ) + endif + call mztvc (ig,vc210, 1, 2, irw_mztf, imu, 0,0,0 ) + call mztvc (ig,vc310, 1, 3, irw_mztf, imu, 0,0,0 ) + call mztvc (ig,vc410, 1, 4, irw_mztf, imu, 0,0,0 ) + + call mzescape_fb (ig) + input_cza = 0 + call NLTEdlvr09_CZALU(ig) + + if (itt_cza.ne.24) then + call mzescape_fh (ig) + input_cza = 1 + call NLTEdlvr09_CZALU(ig) + endif + +c total cooling rate +c smoothing and +c interpolation back to original Pgrid +c + do i = 1, nl + q15umco2_nl(i) = hr110(i) + hr210(i) + hr310(i) + hr410(i) + @ + hr121(i) + enddo + + do i=1,nl + zld(i) = - dble ( alog(pl(i)) ) + enddo + do i=1,n_gcm + zgcmd(i) = - dble( alog(p_gcm(ig,i)) ) + enddo + call zerov( auxdgcm, n_gcm ) + call interdp_limits + @ (auxdgcm,zgcmd,n_gcm,jlowerboundary,jtopboundary, + @ q15umco2_nl,zld,nl,1,nl,1) + call suaviza ( auxdgcm, n_gcm, 1, zgcmd ) + + do i=1,n_gcm + q15umco2_gcm(ig,i) = sngl( auxdgcm(i) ) + enddo + + enddo + + +c end subroutine + return + end + + + +c*********************************************************************** + + subroutine NLTEdlvr09_ZGRID (n_gcm, + @ p_gcm, t_gcm, z_gcm, + @ co2vmr_gcm, n2vmr_gcm, covmr_gcm, o3pvmr_gcm ,mmean_gcm, + @ cpnew_gcm) + +c jul 2011 malv+fgg First version +c*********************************************************************** + + implicit none + + include "dimensions.h" + include "dimphys.h" + include 'nlte_paramdef.h' + include 'nlte_commons.h' + include 'chimiedata.h' + include 'conc.h' + +c Arguments + integer n_gcm + real p_gcm(n_gcm), t_gcm(n_gcm) + real co2vmr_gcm(n_gcm), n2vmr_gcm(n_gcm) + real covmr_gcm(n_gcm), o3pvmr_gcm(n_gcm) + real z_gcm(n_gcm) + real mmean_gcm(n_gcm) + real cpnew_gcm(n_gcm) + +c local variables + integer i, j , iz +! real distancia, meanm, gz, Hkm + real zmin, zmax, deltazz, deltazzy + real nt_gcm(n_gcm) + real mmean_nlte(n_gcm),cpnew_nlte(n_gcm) + +c functions + external hrkday_convert + real hrkday_convert + +c*********************************************************************** + + +! Define working grid for MZ1D model (NL, ZL, ZMIN) +! y otro mas fino para M.Curtis (NZ, ZX, ZXMIN = ZMIN + +! Para ello hace falta una z de ref del GCM, que voy a suponer la inferior + +! Primero, construimos escala z_gcm + +! z_gcm (1) = zmin_gcm ! [km] + + !write (*,*) ' iz, p, g, H, z =', 1, p_gcm(1), z_gcm(1) +! do iz = 2, n_gcm +! do iz=1,n_gcm +! z_gcm(iz)=zlay(iz)/1.e3 + +! meanm = ( co2vmr_gcm(iz)*44. + o3pvmr_gcm(iz)*16. +! @ + n2vmr_gcm(iz)*28. + covmr_gcm(iz)*28. ) +! meanm = meanm / n_avog +! distancia = ( radio + z_gcm(iz-1) )*1.e5 +! gz = gg * masa / ( distancia * distancia ) +! Hkm = 0.5*( t_gcm(iz)+t_gcm(iz-1) ) / ( meanm * gz ) +! Hkm = kboltzman * Hkm *1e-5 ! [km] +! z_gcm(iz) = z_gcm(iz-1) - Hkm * log( p_gcm(iz)/p_gcm(iz-1) ) + + !write (*,*) iz, p_gcm(iz), gz, Hkm, z_gcm(iz) + +! enddo +! Segundo, definimos los límites del modelo, entre las 2 presiones clave + + ! Bottom boundary for NLTE model : Pbottom=2e-2mb=1.974e-5 atm + jlowerboundary = 1 + do while ( p_gcm(jlowerboundary) .gt. Pbottom_atm ) + jlowerboundary = jlowerboundary + 1 + enddo + zmin = z_gcm(jlowerboundary) +! write (*,*) ' jlowerboundary, Pmin, zmin =', +! @ jlowerboundary, p_gcm(jlowerboundary), zmin + + ! Top boundary for NLTE model : Ptop=2e-7mb = 1.974e-5 atm + jtopboundary = jlowerboundary + do while ( p_gcm(jtopboundary) .gt. Ptop_atm ) + jtopboundary = jtopboundary + 1 + enddo + zmax = z_gcm(jtopboundary) +! write (*,*) ' jtopboundary, Pmax, zmax =', +! @ jtopboundary, p_gcm(jtopboundary),zmax + + deltaz = (zmax-zmin) / (nl-1) + do i=1,nl + zl(i) = zmin + (i-1) * deltaz + enddo +! write (*,*) ' ZL grid: dz,zmin,zmax ', deltaz, zl(1),zl(nl) +! Creamos el perfil interpolando + call intersp ( pl,zl,nl, p_gcm,z_gcm,n_gcm, 2) ! [atm] + call intersp ( t,zl,nl, t_gcm,z_gcm,n_gcm, 1) + do i = 1, n_gcm + nt_gcm(i) = 7.339e+21 * p_gcm(i) / t_gcm(i) ! [cm-3] + enddo + call intersp ( nt,zl,nl, nt_gcm,z_gcm,n_gcm, 2) + call intersp (co2vmr,zl,nl, co2vmr_gcm,z_gcm,n_gcm, 1) + call intersp ( n2vmr,zl,nl, n2vmr_gcm,z_gcm,n_gcm, 1) + call intersp ( covmr,zl,nl, covmr_gcm,z_gcm,n_gcm, 1) + call intersp (o3pvmr,zl,nl, o3pvmr_gcm,z_gcm,n_gcm, 1) + call intersp (mmean_nlte,zl,nl,mmean_gcm,z_gcm,n_gcm,1) + call intersp (cpnew_nlte,zl,nl,cpnew_gcm,z_gcm,n_gcm,1) + + + do i = 1, nl + + co2(i) = nt(i) * co2vmr(i) + n2(i) = nt(i) * n2vmr(i) + co(i) = nt(i) * covmr(i) + o3p(i) = nt(i) * o3pvmr(i) + +! hrkday_factor(i) = hrkday_convert( t(i), +! @ co2vmr(i), o3pvmr(i), n2vmr(i), covmr(i) ) + hrkday_factor(i) = hrkday_convert(mmean_nlte(i),cpnew_nlte(i)) + + enddo + + + +c Fine grid for transmittance calculations + + deltazy = (zmax-zmin) / (nzy-1) + do i=1,nzy + zy(i) = zmin + (i-1) * deltazy + enddo +! write (*,*) ' ZY grid: nzy,dzy,zmin,zmax ', +! @ nzy, deltazy, zy(1),zy(nzy) + + call intersp ( py,zy,nzy, p_gcm,z_gcm,n_gcm, 2) ! [atm] + call intersp ( ty,zy,nzy, t_gcm,z_gcm,n_gcm, 1) + call intersp ( nty,zy,nzy, nt_gcm,z_gcm,n_gcm, 2) + + call intersp ( co2y,zy,nzy, co2vmr_gcm,z_gcm,n_gcm, 1) + do i=1,nzy + co2y(i) = co2y(i) * nty(i) + enddo + + + + +c end + return + end + + + + +c*********************************************************************** + + subroutine NLTEdlvr09_CZALU(ig) + +c jul 2011 malv+fgg +c*********************************************************************** + + implicit none + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! common variables and constants + + include 'nlte_paramdef.h' + include 'nlte_commons.h' + +c arguments + + integer ig !ADDED FOR TRACEBACK + +c local variables + +! matrixes and vectors + + real*8 e110(nl), e210(nl), e310(nl), e410(nl) + real*8 e121(nl), e112(nl) + + real*8 f1(nl,nl) + + real*8 cax1(nl,nl), cax2(nl,nl), cax3(nl,nl) + real*8 v1(nl), v2(nl), v3(nl) + + real*8 alf11(nl,nl), alf12(nl,nl) + real*8 alf21(nl,nl), alf31(nl,nl), alf41(nl,nl) + real*8 a11(nl), a1112(nl,nl) + real*8 a1121(nl,nl), a1131(nl,nl), a1141(nl,nl) + real*8 a21(nl), a2131(nl,nl), a2141(nl,nl) + real*8 a2111(nl,nl), a2112(nl,nl) + real*8 a31(nl), a3121(nl,nl), a3141(nl,nl) + real*8 a3111(nl,nl), a3112(nl,nl) + real*8 a41(nl), a4121(nl,nl), a4131(nl,nl) + real*8 a4111(nl,nl), a4112(nl,nl) + real*8 a12(nl), a1211(nl,nl) + real*8 a1221(nl,nl), a1231(nl,nl), a1241(nl,nl) + + real*8 aalf11(nl,nl),aalf21(nl,nl),aalf31(nl,nl),aalf41(nl,nl) + real*8 aa11(nl), aa1121(nl,nl), aa1131(nl,nl), aa1141(nl,nl) + real*8 aa21(nl), aa2111(nl,nl), aa2131(nl,nl), aa2141(nl,nl) + real*8 aa31(nl), aa3111(nl,nl), aa3121(nl,nl), aa3141(nl,nl) + real*8 aa41(nl), aa4111(nl,nl), aa4121(nl,nl), aa4131(nl,nl) + real*8 aa12(nl) + real*8 aa1211(nl,nl), aa1221(nl,nl), aa1231(nl,nl), aa1241(nl,nl) + real*8 aa1112(nl,nl), aa2112(nl,nl), aa3112(nl,nl), aa4112(nl,nl) + + real*8 aaalf11(nl,nl),aaalf21(nl,nl),aaalf31(nl,nl), + & aaalf41(nl,nl) + real*8 aaa11(nl),aaa1121(nl,nl),aaa1131(nl,nl),aaa1141(nl,nl) + real*8 aaa21(nl),aaa2111(nl,nl),aaa2131(nl,nl),aaa2141(nl,nl) + real*8 aaa31(nl),aaa3111(nl,nl),aaa3121(nl,nl),aaa3141(nl,nl) + real*8 aaa41(nl),aaa4111(nl,nl),aaa4121(nl,nl),aaa4131(nl,nl) + + real*8 aaaalf11(nl,nl),aaaalf41(nl,nl) + real*8 aaaa11(nl),aaaa1141(nl,nl) + real*8 aaaa41(nl),aaaa4111(nl,nl) + + + +! populations + real*8 n10(nl), n11(nl) + real*8 n20(nl), n21(nl) + real*8 n30(nl), n31(nl) + real*8 n40(nl), n41(nl) + + +! productions and loses + real*8 d19a1,d19b1,d19c1 + real*8 d19ap1,d19bp1,d19cp1 + real*8 d19a2,d19b2,d19c2 + real*8 d19ap2,d19bp2,d19cp2 + real*8 d19a3,d19b3,d19c3 + real*8 d19ap3,d19bp3,d19cp3 + real*8 d19a4,d19b4,d19c4 + real*8 d19ap4,d19bp4,d19cp4 + + real*8 l11, l12, l21, l31, l41 + real*8 p11, p12, p21, p31, p41 + real*8 p1112, p1211, p1221, p1231, p1241 + real*8 p1121, p1131, p1141 + real*8 p2111, p2112, p2131, p2141 + real*8 p3111, p3112, p3121, p3141 + real*8 p4111, p4112, p4121, p4131 + + + real*8 ps11, ps21, ps31, ps41, ps12 + + real*8 pl11, pl12, pl21, pl31, pl41 + +c local constants and indexes + + integer ii ! decides if output of tv,hr + integer icurt ! decides if read/comp c.matrix + + real*8 co2t + real*8 ftest + + real*8 a11_einst(nl), a12_einst(nl) + real*8 a21_einst(nl), a31_einst(nl), a41_einst(nl) + real tsurf + + real*8 nu11, nu12, nu121, nu21, nu31, nu41 + + integer i, j, ik, isot , icurtishb + integer i_by15sh, i_col020, i_col010636 + + +c external functions and subroutines + + external planckdp + real*8 planckdp + +! subroutines called: +! mz4sub, dmzout, readc_mz4, mztf + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! start program + + + ii = 4 + icurt = 1 + + call zero4v( aa11, aa21, aa31, aa41, nl) + call zero4m( aa1121, aa1131, aa1141, aalf11, nl) + call zero4m( aa2111, aa2131, aa2141, aalf21, nl) + call zero4m( aa3111, aa3121, aa3141, aalf31, nl) + call zero4m( aa4111, aa4121, aa4131, aalf41, nl) + call zero4m( aa1112, aa2112, aa3112, aa4112, nl) + call zero4m( aa1211, aa1221, aa1231, aa1241, nl) + call zero3v( aaa41, aaa31, aaa11, nl ) + call zero3m( aaa4111, aaa4131, aaalf41, nl) + call zero3m( aaa3111, aaa3141, aaalf31, nl) + call zero3m( aaa1131, aaa1141, aaalf11, nl) + call zero2v( aaaa11, aaaa41, nl ) + call zero2m( aaaa1141, aaaalf11, nl) + call zero2m( aaaa4111, aaaalf41, nl) + + !write (*,*) ' --- c z a simple --- input_cza : ', input_cza + + + call zero3v (vt11,vt12,vt13,nl) + call zero3v (vt21,vt22,vt23,nl) + call zero3v (vt31,vt32,vt33,nl) + call zero3v (vt41,vt42,vt43,nl) + + call zero3v (hr110,hr121,hr132,nl) + call zero3v (hr210,hr221,hr232,nl) + call zero3v (hr310,hr321,hr332,nl) + call zero3v (hr410,hr421,hr432,nl) + call zero3v (sl110,sl121,sl132,nl) + call zero3v (sl210,sl221,sl232,nl) + call zero3v (sl310,sl321,sl332,nl) + call zero3v (sl410,sl421,sl432,nl) + + call zero4v (el11,el21,el31,el41,nl) + call zero4v (e110,e210,e310,e410,nl) + call zero3v (el12,e121,e112,nl) + + call zero3m (cax1,cax2,cax3,nl) + call zerom (f1,nl) + call zero3v (v1,v2,v3,nl) + + call zero4m (alf11,alf21,alf31,alf41,nl) + call zerom (alf12,nl) + call zero2v (a11,a12,nl) + call zero3v (a21,a31,a41,nl) + + call zero3m (a1121,a1131,a1141,nl) + call zerom (a1112,nl) + + call zero3m (a1221,a1231,a1241,nl) + call zerom (a1211,nl) + + call zero2m (a2111,a2112,nl) + call zero2m (a2131,a2141,nl) + call zero2m (a3111,a3112,nl) + call zero2m (a3121,a3141,nl) + call zero2m (a4111,a4112,nl) + call zero2m (a4121,a4131,nl) + + + call zero4v (n11,n21,n31,n41,nl) + + nu11 = nu(1,1) + nu12 = nu(1,2) + nu121 = nu12-nu11 + + nu21 = nu(2,1) + + nu31 = nu(3,1) + + nu41 = nu(4,1) + + ftest = 1.d0 + i_by15sh = 1 + i_col020 = 1 + + i_col010636 = 1 + + + 101 format(a1) + 180 format(a80) + + +c establishing molecular populations needed as input + do i=1,nl + n10(i) = dble( co2(i) * imr(1) ) + n20(i) = dble( co2(i) * imr(2) ) + n30(i) = dble( co2(i) * imr(3) ) + n40(i) = dble( co2(i) * imr(4) ) + if ( input_cza.ge.1 ) then + n11(i) = n10(i) *2.d0 *exp( dble(-ee*nu(1,1))/v626t1(i) ) + n21(i) = n20(i) *2.d0 *exp( dble(-ee*nu(2,1))/v628t1(i) ) + n31(i) = n30(i) *2.d0* exp( dble(-ee*nu(3,1))/v636t1(i) ) + n41(i) = n40(i) *2.d0* exp( dble(-ee*nu(4,1))/v627t1(i) ) + end if + enddo + +cc +cc curtis matrix calculation +cc + if ( input_cza.ge.1 ) then + + if (itt_cza.eq.15 ) then + + call cm15um_hb_simple ( ig,icurt ) + + elseif (itt_cza.eq.13) then + + call mztvc_626fh(ig) + + endif + + endif + + + + do 4,i=nl,1,-1 !---------------------------------------------- + + co2t = dble ( co2(i) *(imr(1)+imr(3)+imr(2)+imr(4)) ) + + call getk ( t(i) ) + + ps11 = 0.d0 + ps21 = 0.d0 + ps31 = 0.d0 + ps41 = 0.d0 + ps12 = 0.d0 + + ! V-T productions and losses V-T + + isot = 1 + d19b1 = dble(k19ba(isot)*co2t+k19bb(isot)*n2(i)) + @ + dble(k19bc(isot)*co(i)) + d19c1 = dble(k19ca(isot)*co2t+k19cb(isot)*n2(i)) + @ + dble(k19cc(isot)*co(i)) + d19bp1 = dble( k19bap(isot)*co2t + k19bbp(isot)*n2(i) ) + @ + dble( k19bcp(isot)*co(i) ) + d19cp1 = dble( k19cap(isot)*co2t + k19cbp(isot)*n2(i) ) + @ + dble( k19ccp(isot)*co(i) ) + isot = 2 + d19c2 =dble(k19ca(isot)*co2t+k19cb(isot)*n2(i)) + @ + dble(k19cc(isot)*co(i)) + d19cp2 =dble( k19cap(isot)*co2t + k19cbp(isot)*n2(i) ) + @ + dble( k19ccp(isot)*co(i) ) + isot = 3 + d19c3 =dble(k19ca(isot)*co2t+k19cb(isot)*n2(i)) + @ + dble(k19cc(isot)*co(i)) + d19cp3 =dble( k19cap(isot)*co2t + k19cbp(isot)*n2(i) ) + @ + dble( k19ccp(isot)*co(i) ) + isot = 4 + d19c4 =dble(k19ca(isot)*co2t+k19cb(isot)*n2(i)) + @ + dble(k19cc(isot)*co(i)) + d19cp4 =dble( k19cap(isot)*co2t + k19cbp(isot)*n2(i) ) + @ + dble(k19ccp(isot)*co(i) ) + ! + l11 = d19c1 + k20c(1)*dble(o3p(i)) + p11 = ( d19cp1 + k20cp(1)*dble(o3p(i)) ) * n10(i) + l21 = d19c2 + k20c(2)*dble(o3p(i)) + p21 = ( d19cp2 + k20cp(2)*dble(o3p(i)) ) *n20(i) + l31 = d19c3 + k20c(3)*dble(o3p(i)) + p31 = ( d19cp3 + k20cp(3)*dble(o3p(i)) ) *n30(i) + l41 = d19c4 + k20c(4)*dble(o3p(i)) + p41 = ( d19cp4 + k20cp(4)*dble(o3p(i)) ) *n40(i) + + ! Addition of V-V + + l11 = l11 + k21cp(2)*n20(i) + k21cp(3)*n30(i) + k21cp(4)*n40(i) + p1121 = k21c(2) * n10(i) + p1131 = k21c(3) * n10(i) + p1141 = k21c(4) * n10(i) + ! + l21 = l21 + k21c(2)*n10(i) + k23k21c*n30(i) + k24k21c*n40(i) + p2111 = k21cp(2) * n20(i) + p2131 = k23k21cp * n20(i) + p2141 = k24k21cp * n20(i) + ! + l31 = l31 + k21c(3)*n10(i) + k23k21cp*n20(i) + k34k21c*n40(i) + p3111 = k21cp(3)* n30(i) + p3121 = k23k21c * n30(i) + p3141 = k34k21cp* n30(i) + ! + l41 = l41 + k21c(4)*n10(i) + k24k21cp*n20(i) + k34k21cp*n30(i) + p4111 = k21cp(4)* n40(i) + p4121 = k24k21c * n40(i) + p4131 = k34k21c * n40(i) + + + if ( input_cza.ge.1 ) then + + l12 = d19b1 + @ + k20b(1)*dble(o3p(i)) + @ + k21b(1)*n10(i) + @ + k33c*( n20(i) + n30(i) + n40(i) ) + p12 = k21bp(1)*n11(i) * n11(i) + p1211 = d19bp1 + k20bp(1)*dble(o3p(i)) + p1221 = k33cp(2)*n11(i) + p1231 = k33cp(3)*n11(i) + p1241 = k33cp(4)*n11(i) + + l11 = l11 + d19bp1 + @ + k20bp(1)*dble(o3p(i)) + @ + 2.d0 * k21bp(1) * n11(i) + @ + k33cp(2)*n21(i) + k33cp(3)*n31(i) + k33cp(4)*n41(i) + p1112 = d19b1 + @ + k20b(1)*dble(o3p(i)) + @ + 2.d0*k21b(1)*n10(i) + @ + k33c*( n20(i) + n30(i) + n40(i) ) + + l21 = l21 + k33cp(2)*n11(i) + p2112 = k33c*n20(i) + + l31 = l31 + k33cp(3)*n11(i) + p3112 = k33c*n30(i) + + l41 = l41 + k33cp(4)*n11(i) + p4112 = k33c*n40(i) + + end if + + + ! Changes in local losses for ITT=13,15 cases + + a21_einst(i) = 1.3452d00 * 1.8 / 4.0 * taustar21(i) + a31_einst(i) = 1.1878d00 * 1.8 / 4.0 * taustar31(i) + a41_einst(i) = 1.2455d00 * 1.8 / 4.0 * taustar41(i) + + l21 = l21 + a21_einst(i) + l31 = l31 + a31_einst(i) + l41 = l41 + a41_einst(i) + + if (input_cza.ge.1 .and. itt_cza.eq.13) then + a12_einst(i) = 4.35d00 / 3.0d0 * 1.8 / 4.0 * taustar12(i) + l12=l12+a12_einst(i) + endif + + if (itt_cza.eq.24) then + a11_einst(i) = a11_einst(i) * 1.8 / 4.0 * taustar11(i) + l11 = l11 + a11_einst(i) + endif + + + ! vectors and matrices for the formulation + + a11(i) = dble(gamma*nu11**3.) * 1.d0/2.d0 * (p11+ps11) / + @ (n10(i)*l11) + a1121(i,i) = dble((nu11/nu21))**3.d0 * n20(i)/n10(i) *p1121/l11 + a1131(i,i) = dble((nu11/nu31))**3.d0 * n30(i)/n10(i) *p1131/l11 + a1141(i,i) = dble((nu11/nu41))**3.d0 * n40(i)/n10(i) *p1141/l11 + e110(i) = 2.d0* dble(vlight*nu11**2.) * 1.d0/2.d0 / + @ ( n10(i) * l11 ) + + a21(i) = dble( gamma*nu21**3.) * 1.d0/2.d0 * + @ (p21+ps21)/(n20(i)*l21) + a2111(i,i) = dble((nu21/nu11))**3.d0 * n10(i)/n20(i) *p2111/l21 + a2131(i,i) = dble((nu21/nu31))**3.d0 * n30(i)/n20(i) *p2131/l21 + a2141(i,i) = dble((nu21/nu41))**3.d0 * n40(i)/n20(i) *p2141/l21 + e210(i) = 2.d0*dble(vlight*nu21**2.) * 1.d0/2.d0 / + @ ( n20(i) * l21 ) + + a31(i) = dble(gamma*nu31**3.) * 1.d0/2.d0 * (p31+ps31) / + @ (n30(i)*l31) + a3111(i,i) = dble((nu31/nu11))**3.d0 * n10(i)/n30(i) *p3111/l31 + a3121(i,i) = dble((nu31/nu21))**3.d0 * n20(i)/n30(i) *p3121/l31 + a3141(i,i) = dble((nu31/nu41))**3.d0 * n40(i)/n30(i) *p3141/l31 + e310(i) = 2.d0*dble(vlight*nu31**2.) * 1.d0/2.d0 / + @ ( n30(i) * l31 ) + + a41(i) = dble(gamma*nu41**3.) * 1.d0/2.d0 * (p41+ps41) / + @ (n40(i)*l41) + a4111(i,i) = dble((nu41/nu11))**3.d0 * n10(i)/n40(i) *p4111/l41 + a4121(i,i) = dble((nu41/nu21))**3.d0 * n20(i)/n40(i) *p4121/l41 + a4131(i,i) = dble((nu41/nu31))**3.d0 * n30(i)/n40(i) *p4131/l41 + e410(i) = 2.d0*dble(vlight*nu41**2.) * 1.d0/2.d0 / + @ ( n40(i) * l41 ) + + if (input_cza.ge.1) then + + a1112(i,i) = dble((nu11/nu121))**3.d0 * n11(i)/n10(i) * + @ p1112/l11 + a2112(i,i) = dble((nu21/nu121))**3.d0 * n11(i)/n20(i) * + @ p2112/l21 + a3112(i,i) = dble((nu31/nu121))**3.d0 * n11(i)/n30(i) * + @ p3112/l31 + a4112(i,i) = dble((nu41/nu121))**3.d0 * n11(i)/n40(i) * + @ p4112/l41 + e112(i) = -2.d0*dble(vlight*nu11**3.)/nu121 /2.d0 / + @ ( n10(i)*l11 ) + a12(i) = dble( gamma*nu121**3.) *2.d0/4.d0* (p12+ps12)/ + @ (n11(i)*l12) + a1211(i,i) = dble((nu121/nu11))**3.d0 * n10(i)/n11(i) * + @ p1211/l12 + a1221(i,i) = dble((nu121/nu21))**3.d0 * n20(i)/n11(i) * + @ p1221/l12 + a1231(i,i) = dble((nu121/nu31))**3.d0 * n30(i)/n11(i) * + @ p1231/l12 + a1241(i,i) = dble((nu121/nu41))**3.d0 * n40(i)/n11(i) * + @ p1241/l12 + e121(i) = 2.d0*dble(vlight*nu121**2.) *2.d0/4.d0 / + @ ( n11(i) * l12 ) + + end if + + + 4 continue !------------------------------------------------------- + + + ! Change C.M. + + do i=1,nl + do j=1,nl + c210(i,j) = 0.0d0 + c310(i,j) = 0.0d0 + c410(i,j) = 0.0d0 + end do + end do + if ( itt_cza.eq.13 ) then + do i=1,nl + do j=1,nl + c121(i,j) = 0.0d0 + end do + end do + endif + !Añadido para hacer diagonal C121 +! if ( itt_cza.eq.15 ) then +! do i=1,nl +! do j=1,nl +! if(abs(i-j).eq.1.or.abs(i-j).eq.2) c121(i,j) = 0.0d0 +! end do +! end do +! endif + if ( itt_cza.eq.24 ) then + do i=1,nl + do j=1,nl + c110(i,j) = 0.0d0 + end do + end do + endif + + ! Lower Boundary + tsurf = t(1) + tsurf_excess + do i=1,nl + sl110(i) = sl110(i) + vc110(i) * planckdp( tsurf, nu11 ) + sl210(i) = sl210(i) + vc210(i) * planckdp( tsurf, nu21 ) + sl310(i) = sl310(i) + vc310(i) * planckdp( tsurf, nu31 ) + sl410(i) = sl410(i) + vc410(i) * planckdp( tsurf, nu41 ) + end do + if (input_cza.ge.1) then + do i=1,nl + sl121(i) = sl121(i) + vc121(i) * planckdp( tsurf, nu121 ) + end do + endif + + + !!!!!!!!!!!! Solucion del sistema + + !! Paso 0 : Calculo de los alphas alf11, alf21, alf31, alf41, alf12 + + call unit ( cax2, nl ) + + call diago ( cax1, e110, nl ) + call mulmm ( cax3, cax1,c110, nl ) +! cax3=matmul(cax1,c110) + call resmm ( alf11, cax2,cax3, nl ) + + call diago ( cax1, e210, nl ) + call mulmm ( cax3, cax1,c210, nl ) +! cax3=matmul(cax1,c210) + call resmm ( alf21, cax2,cax3, nl ) + + call diago ( cax1, e310, nl ) + call mulmm ( cax3, cax1,c310, nl ) +! cax3=matmul(cax1,c310) + call resmm ( alf31, cax2,cax3, nl ) + ! + call diago ( cax1, e410, nl ) + call mulmm ( cax3, cax1,c410, nl ) +! cax3=matmul(cax1,c410) + call resmm ( alf41, cax2,cax3, nl ) + ! +! if(ig.eq.2223.and.input_cza.eq.1) then +! open(168,file='output_curtis_c121diagminus2.dat') +! do i=1,nl +! do j=1,nl +! write(168,*)i,j,c110(i,j),c121(i,j) +! enddo +! enddo +! close(168) +! open(178,file='output_taustar.dat') +! do i=1,nl +! write(178,*)i,taustar21(i),taustar31(i),taustar41(i) +! enddo +! close(178) +! endif + if (input_cza.ge.1) then + call diago ( cax1, e121, nl ) + call mulmm ( cax3, cax1,c121, nl ) +! cax3=matmul(cax1,c121) + call resmm ( alf12, cax2,cax3, nl ) + endif + + !! Paso 1 : Calculo de vectores y matrices con 1 barra (aa***) + + if (input_cza.eq.0) then ! Skip paso 1, pues el12 no se calcula + + ! el11 + call sypvvv( aa11, a11,e110,sl110, nl ) + call samem( aa1121, a1121, nl ) + call samem( aa1131, a1131, nl ) + call samem( aa1141, a1141, nl ) + call samem( aalf11, alf11, nl ) + + ! el21 + call sypvvv( aa21, a21,e210,sl210, nl ) + call samem( aa2111, a2111, nl ) + call samem( aa2131, a2131, nl ) + call samem( aa2141, a2141, nl ) + call samem( aalf21, alf21, nl ) + + ! el31 + call sypvvv( aa31, a31,e310,sl310, nl ) + call samem( aa3111, a3111, nl ) + call samem( aa3121, a3121, nl ) + call samem( aa3141, a3141, nl ) + call samem( aalf31, alf31, nl ) + + ! el41 + call sypvvv( aa41, a41,e410,sl410, nl ) + call samem( aa4111, a4111, nl ) + call samem( aa4121, a4121, nl ) + call samem( aa4131, a4131, nl ) + call samem( aalf41, alf41, nl ) + + + else ! (input_cza.ge.1) , FH ! + + + call sypvvv( v1, a12,e121,sl121, nl ) ! a12 + e121 * sl121 + + ! aa11 + call sypvvv( v2, a11,e110,sl110, nl ) + call trucommvv( aa11 , alf12,a1112,v2, v1, nl ) + + ! aalf11 + call invdiag( cax1, a1112, nl ) + call mulmm( cax2, alf12, cax1, nl ) ! alf12 * (1/a1112) +! cax2=matmul(alf12,cax1) + call mulmm( cax3, cax2, alf11, nl ) +! cax3=matmul(cax2,alf11) + + call resmm( aalf11, cax3, a1211, nl ) + ! aa1121 + call trucodiag(aa1121, alf12,a1112,a1121, a1221, nl) + ! aa1131 + call trucodiag(aa1131, alf12,a1112,a1131, a1231, nl) + ! aa1141 + call trucodiag(aa1141, alf12,a1112,a1141, a1241, nl) + + + ! aa21 + call sypvvv( v2, a21,e210,sl210, nl ) + call trucommvv( aa21 , alf12,a2112,v2, v1, nl ) + + ! aalf21 + call invdiag( cax1, a2112, nl ) + call mulmm( cax2, alf12, cax1, nl ) ! alf12 * (1/a2112) +! cax2=matmul(alf12,cax1) + call mulmm( cax3, cax2, alf21, nl ) +! cax3=matmul(cax2,alf21) + call resmm( aalf21, cax3, a1221, nl ) + ! aa2111 + call trucodiag(aa2111, alf12,a2112,a2111, a1211, nl) + ! aa2131 + call trucodiag(aa2131, alf12,a2112,a2131, a1231, nl) + ! aa2141 + call trucodiag(aa2141, alf12,a2112,a2141, a1241, nl) + + + ! aa31 + call sypvvv( v2, a31,e310,sl310, nl ) + call trucommvv( aa31 , alf12,a3112,v2, v1, nl ) + ! aalf31 + call invdiag( cax1, a3112, nl ) + call mulmm( cax2, alf12, cax1, nl ) ! alf12 * (1/a3112) +! cax2=matmul(alf12,cax1) + call mulmm( cax3, cax2, alf31, nl ) +! cax3=matmul(cax2,alf31) + call resmm( aalf31, cax3, a1231, nl ) + ! aa3111 + call trucodiag(aa3111, alf12,a3112,a3111, a1211, nl) + ! aa3121 + call trucodiag(aa3121, alf12,a3112,a3121, a1221, nl) + ! aa3141 + call trucodiag(aa3141, alf12,a3112,a3141, a1241, nl) + + + ! aa41 + call sypvvv( v2, a41,e410,sl410, nl ) + call trucommvv( aa41 , alf12,a4112,v2, v1, nl ) + ! aalf41 + call invdiag( cax1, a4112, nl ) + call mulmm( cax2, alf12, cax1, nl ) ! alf12 * (1/a4112) +! cax2=matmul(alf12,cax1) + call mulmm( cax3, cax2, alf41, nl ) +! cax3=matmul(cax2,alf41) + call resmm( aalf41, cax3, a1241, nl ) + ! aa4111 + call trucodiag(aa4111, alf12,a4112,a4111, a1211, nl) + ! aa4121 + call trucodiag(aa4121, alf12,a4112,a4121, a1221, nl) + ! aa4131 + call trucodiag(aa4131, alf12,a4112,a4131, a1231, nl) + + endif ! Final caso input_cza.ge.1 + + + !! Paso 2 : Calculo de vectores y matrices con 2 barras (aaa***) + + ! aaalf41 + call invdiag( cax1, aa4121, nl ) + call mulmm( cax2, aalf21, cax1, nl ) ! alf21 * (1/a4121) +! cax2=matmul(aalf21,cax1) + call mulmm( cax3, cax2, aalf41, nl ) +! cax3=matmul(cax2,aalf41) + call resmm( aaalf41, cax3, aa2141, nl ) + ! aaa41 + call trucommvv(aaa41, aalf21,aa4121,aa41, aa21, nl) + ! aaa4111 + call trucodiag(aaa4111, aalf21,aa4121,aa4111, aa2111, nl) + ! aaa4131 + call trucodiag(aaa4131, aalf21,aa4121,aa4131, aa2131, nl) + + ! aaalf31 + call invdiag( cax1, aa3121, nl ) + call mulmm( cax2, aalf21, cax1, nl ) ! alf21 * (1/a3121) +! cax2=matmul(aalf21,cax1) + call mulmm( cax3, cax2, aalf31, nl ) +! cax3=matmul(cax2,aalf31) + call resmm( aaalf31, cax3, aa2131, nl ) + ! aaa31 + call trucommvv(aaa31, aalf21,aa3121,aa31, aa21, nl) + ! aaa3111 + call trucodiag(aaa3111, aalf21,aa3121,aa3111, aa2111, nl) + ! aaa3141 + call trucodiag(aaa3141, aalf21,aa3121,aa3141, aa2141, nl) + + ! aaalf11 + call invdiag( cax1, aa1121, nl ) + call mulmm( cax2, aalf21, cax1, nl ) ! alf21 * (1/a1121) +! cax2=matmul(aalf21,cax1) + call mulmm( cax3, cax2, aalf11, nl ) +! cax3=matmul(cax2,aalf11) + call resmm( aaalf11, cax3, aa2111, nl ) + ! aaa11 + call trucommvv(aaa11, aalf21,aa1121,aa11, aa21, nl) + ! aaa1131 + call trucodiag(aaa1131, aalf21,aa1121,aa1131, aa2131, nl) + ! aaa1141 + call trucodiag(aaa1141, aalf21,aa1121,aa1141, aa2141, nl) + + + !! Paso 3 : Calculo de vectores y matrices con 3 barras (aaaa***) + + ! aaaalf41 + call invdiag( cax1, aaa4131, nl ) + call mulmm( cax2, aaalf31, cax1, nl ) ! aaalf31 * (1/aaa4131) +! cax2=matmul(aaalf31,cax1) + call mulmm( cax3, cax2, aaalf41, nl ) +! cax3=matmul(cax2,aaalf41) + call resmm( aaaalf41, cax3, aaa3141, nl ) + + ! aaaa41 + call trucommvv(aaaa41, aaalf31,aaa4131,aaa41, aaa31, nl) + ! aaaa4111 + call trucodiag(aaaa4111, aaalf31,aaa4131,aaa4111,aaa3111, nl) + + ! aaaalf11 + call invdiag( cax1, aaa1131, nl ) + call mulmm( cax2, aaalf31, cax1, nl ) ! aaalf31 * (1/aaa4131) +! cax2=matmul(aaalf31,cax1) + call mulmm( cax3, cax2, aaalf11, nl ) +! cax3=matmul(cax2,aaalf11) + call resmm( aaaalf11, cax3, aaa3111, nl ) + ! aaaa11 + call trucommvv(aaaa11, aaalf31,aaa1131,aaa11, aaa31, nl) + ! aaaa1141 + call trucodiag(aaaa1141, aaalf31,aaa1131,aaa1141,aaa3141, nl) + + + !! Paso 4 : Calculo de vectores y matrices finales y calculo de J1 + + call trucommvv(v1, aaaalf41,aaaa1141,aaaa11, aaaa41, nl) + ! + call invdiag( cax1, aaaa1141, nl ) + call mulmm( cax2, aaaalf41, cax1, nl ) ! aaaalf41 * (1/aaaa1141) +! cax2=matmul(aaaalf41,cax1) + call mulmm( cax3, cax2, aaaalf11, nl ) +! cax3=matmul(cax2,aaaalf11) + call resmm( cax1, cax3, aaaa4111, nl ) + ! + call LUdec ( el11, cax1, v1, nl, nl2 ) + + ! Solucion para el41 + call sypvmv( v1, aaaa41, aaaa4111,el11, nl ) + call LUdec ( el41, aaaalf41, v1, nl, nl2 ) + + ! Solucion para el31 + call sypvmv( v2, aaa31, aaa3111,el11, nl ) + call sypvmv( v1, v2, aaa3141,el41, nl ) + call LUdec ( el31, aaalf31, v1, nl, nl2 ) + + ! Solucion para el21 + call sypvmv( v3, aa21, aa2111,el11, nl ) + call sypvmv( v2, v3, aa2131,el31, nl ) + call sypvmv( v1, v2, aa2141,el41, nl ) + call LUdec ( el21, aalf21, v1, nl, nl2 ) + + !!! + el11(1) = planckdp( t(1), nu11 ) + el21(1) = planckdp( t(1), nu21 ) + el31(1) = planckdp( t(1), nu31 ) + el41(1) = planckdp( t(1), nu41 ) + el11(nl) = 2.d0 * el11(nl-1) - el11(nl2) + el21(nl) = 2.d0 * el21(nl-1) - el21(nl2) + el31(nl) = 2.d0 * el31(nl-1) - el31(nl2) + el41(nl) = 2.d0 * el41(nl-1) - el41(nl2) + + call mulmv ( v1, c110,el11, nl ) + call sumvv ( hr110, v1,sl110, nl ) + + ! Solucion para el12 + if (input_cza.ge.1) then + + call sypvmv( v1, a12, a1211,el11, nl ) + call sypvmv( v3, v1, a1221,el21, nl ) + call sypvmv( v2, v3, a1231,el31, nl ) + call sypvmv( v1, v2, a1241,el41, nl ) + call LUdec ( el12, alf12, v1, nl, nl2 ) + + el12(1) = planckdp( t(1), nu121 ) + el12(nl) = 2.d0 * el12(nl-1) - el12(nl2) + + if (itt_cza.eq.15) then + call mulmv ( v1, c121,el12, nl ) + call sumvv ( hr121, v1,sl121, nl ) + endif + + end if + + + + if (input_cza.lt.1) then + + do i=1,nl + pl11 = el11(i)/dble( gamma * nu11**3.0d0 * 1./2. / n10(i) ) + pl21 = el21(i)/dble( gamma * nu21**3.0d0 * 1./2. / n20(i) ) + pl31 = el31(i)/dble( gamma * nu31**3.0d0 * 1./2. / n30(i) ) + pl41 = el41(i)/dble( gamma * nu41**3.0d0 * 1./2. / n40(i) ) + vt11(i) = dble(-ee*nu11) / log( abs(pl11) / (2.0d0*n10(i)) ) + vt21(i) = dble(-ee*nu21) / log( abs(pl21) / (2.0d0*n20(i)) ) + vt31(i) = dble(-ee*nu31) / log( abs(pl31) / (2.0d0*n30(i)) ) + vt41(i) = dble(-ee*nu41) / log( abs(pl41) / (2.0d0*n40(i)) ) + hr210(i) = sl210(i) - hplanck*vlight*nu21 * a21_einst(i)*pl21 + hr310(i) = sl310(i) - hplanck*vlight*nu31 * a31_einst(i)*pl31 + hr410(i) = sl410(i) - hplanck*vlight*nu41 * a41_einst(i)*pl41 +! hr410(i) = 0. + enddo + + call dinterconnection ( v626t1, vt11 ) + call dinterconnection ( v628t1, vt21 ) + call dinterconnection ( v636t1, vt31 ) + call dinterconnection ( v627t1, vt41 ) + + else + + do i=1,nl + pl21 = el21(i)/dble( gamma * nu21**3.0d0 * 1./2. / n20(i) ) + pl31 = el31(i)/dble( gamma * nu31**3.0d0 * 1./2. / n30(i) ) + pl41 = el41(i)/dble( gamma * nu41**3.0d0 * 1./2. / n40(i) ) + hr210(i) = sl210(i) - hplanck*vlight*nu21 * a21_einst(i)*pl21 + hr310(i) = sl310(i) - hplanck*vlight*nu31 * a31_einst(i)*pl31 + hr410(i) = sl410(i) - hplanck*vlight*nu41 * a41_einst(i)*pl41 +! hr410(i) = 0. + if (itt_cza.eq.13) then + pl12 = el12(i)/dble(gamma*nu121**3.0d0*2./4./n11(i)) + hr121(i) = - hplanck*vlight * nu121 * a12_einst(i) * pl12 + hr121(i) = hr121(i) + sl121(i) + endif + enddo + + endif + + ! K/Dday + do i=1,nl + hr110(i)=hr110(i)*( hrkday_factor(i) / nt(i) ) + hr210(i)=hr210(i)*( hrkday_factor(i) / nt(i) ) + hr310(i)=hr310(i)*( hrkday_factor(i) / nt(i) ) + hr410(i)=hr410(i)*( hrkday_factor(i) / nt(i) ) + hr121(i)=hr121(i)*( hrkday_factor(i) / nt(i) ) + end do + + + +c output + + !codigo = codeout + !call dmzout_tv ( 1 ) + !call dmzout_hr ( 1 ) + +c final subrutina + return + end + +c*********************************************************************** +c hrkday_convert.f +c +c fortran function that returns the factor for conversion from +c hr' [erg s-1 cm-3] to hr [ k day-1 ] +c +c mar 2010 fgg adapted to GCM +c jan 99 malv add o2 as major component. +c ago 98 malv also returns cp_avg,pm_avg +c jul 98 malv first version. +c*********************************************************************** + + function hrkday_convert + @ ( mmean_nlte,cpmean_nlte ) + + implicit none + + include 'comcstfi.h' + include 'param.h' + +c argumentos + real mmean_nlte,cpmean_nlte + real hrkday_convert + +ccccccccccccccccccccccccccccccccccccc + + hrkday_convert = daysec * n_avog / + & ( cpmean_nlte * 1.e4 * mmean_nlte ) + +c end + return + end + +c*********************************************************************** + subroutine sypvvv(a,b,c,d,n) +c a(i)=b(i)+c(i)*d(i) +c jul 2011 malv+fgg +c*********************************************************************** + real*8 a(n),b(n),c(n),d(n) + integer n,i + do 1,i=2,n-1 + a(i)= b(i) + c(i) * d(i) + 1 continue + a(1) = 0.0d0 + a(n) = 0.0d0 + return + end + +c*********************************************************************** + subroutine sypvmv(v,u,c,w,n) +c inputs: matriz diagonal c , vectores u,w +c output: vector v +c Operacion a realizar: v = u + c * w + +c jul 2011 malv+fgg +c*********************************************************************** + real*8 v(n),u(n),c(n,n),w(n) + integer n,i + do 1,i=2,n-1 + v(i)= u(i) + c(i,i) * w(i) + 1 continue + v(1) = 0.0d0 + v(n) = 0.0d0 + return + end + +c*********************************************************************** + subroutine trucommvv(v,b,c,u,w,n) +c inputs: matrices b,c , vectores u,w +c output: vector v +c Operacion a realizar: v = b * c^(-1) * u + w +c La matriz c va a ser invertida +c c es diagonal, b no +c Aprovechamos esa condicion para invertir c, y acelerar el calculo +c jul 2011 malv+fgg +c*********************************************************************** + real*8 v(n),b(n,n),c(n,n),u(n),w(n), sum + integer n,i,j,k + do 1,i=2,n-1 + sum=0.0d0 + do 2,j=2,n-1 + sum=sum+ (b(i,j)) * (u(j)/c(j,j)) + 2 continue + v(i) = sum + w(i) + 1 continue + v(1) = 0.d0 + v(n) = 0.d0 + return + end + +c*********************************************************************** + subroutine trucodiag(a,b,c,d,e,n) +c inputs: matrices b,c,d,e +c output: matriz diagonal a +c Operacion a realizar: a = b * c^(-1) * d + e +c La matriz c va a ser invertida +c Todas las matrices de entrada son diagonales excepto b +c Aprovechamos esa condicion para invertir c, acelerar el calculo, y +c ademas, para forzar que a sea diagonal +c jul 2011 malv+fgg +c*********************************************************************** + real*8 a(n,n),b(n,n),c(n,n),d(n,n),e(n,n), sum + integer n,i,j,k + do 1,i=2,n-1 + sum=0.0d0 + do 2,j=2,n-1 + sum=sum+ (b(i,j)) * (d(j,j)/c(j,j)) + 2 continue + a(i,i) = sum + e(i,i) + 1 continue + do k=1,n + a(n,k) = 0.0d0 + a(1,k) = 0.0d0 + a(k,1) = 0.0d0 + a(k,n) = 0.0d0 + end do + return + end + +c*********************************************************************** + subroutine invdiag(a,b,n) +c inverse of a diagonal matrix +c jul 2011 malv +c*********************************************************************** + implicit none + + integer n,i,j,k + real*8 a(n,n),b(n,n) + + do 1,i=2,n-1 + do 2,j=2,n-1 + if (i.eq.j) then + a(i,j) = 1.d0/b(i,i) + else + a(i,j)=0.0d0 + end if + 2 continue + 1 continue + do k=1,n + a(n,k) = 0.0d0 + a(1,k) = 0.0d0 + a(k,1) = 0.0d0 + a(k,n) = 0.0d0 + end do + return + end Index: trunk/LMDZ.MARS/libf/phymars/nltedefs.h =================================================================== --- trunk/LMDZ.MARS/libf/phymars/nltedefs.h (revision 496) +++ (revision ) @@ -1,52 +1,0 @@ -! NLTE parameters: - - integer nl ! actual # alt in NLTE module - parameter ( nl=20 ) - !real deltaz - !parameter ( deltaz=5.0 ) ! Good option for Mars - ! Asegurarse que el conjunto de valores - ! (zmin,nl,deltaz) no se salen de los - ! límites del grid (zxmin,nz,deltazx) - integer nl2 ! = nl-2, needed for matrix inversion (mmh2) - parameter ( nl2=nl-2 ) - - integer nzy - parameter ( nzy = (nl-1)*4 + 1 ) ! Fine grid for mztud.f - !real deltazy - !parameter ( deltazy = deltaz*4.0 ) - -! Other NLTE parameters: - integer nisot ! number of isotopes considered - integer nb ! number of bands included - integer nbmax_jt ! number of bands for solar heating - parameter ( nisot=4, nb=41, nbmax_jt=47 ) - - integer nhist ! # of temps in histogr. - parameter ( nhist = 36 ) ! (get it from histograms!) - - integer nmax_freq ! maximum number of points - parameter ( nmax_freq = 40000 ) ! for overlap-freq integration - ! If dv (tcr_15um.drv) is very - ! small this must be increased. - - integer nbox_max - parameter ( nbox_max = 70 ) ! max.# boxes in histogram - -! Parameter for the composite vectors and matrixes of the compact-LU method - integer nl5 - parameter ( nl5 = nl * 5 ) - -! NLTE parameters that were needed by solar10 and are still in use - integer ngroup ! normally we use 0 & 10 only - parameter ( ngroup=10 ) - integer nisos ! #isotps para los vectores jt - parameter ( nisos = 9 ) - integer nfile,nfile1 ! reminiscencia de cuando se - parameter ( nfile=5, nfile1=4 ) ! leian las diff.hr desde - ! ficheros externos -! NLTE Parameters for JT calculations - integer nsublayers ! subdivision para el fine grid - parameter ( nsublayers = 50 ) ! called jj in the fot_alljt it - ! is usually 10 for vert. paths - ! or if you wish, for smallSZA, - ! and 50 for oblique (SZA>90) Index: trunk/LMDZ.MARS/libf/phymars/suaviza.F =================================================================== --- trunk/LMDZ.MARS/libf/phymars/suaviza.F (revision 496) +++ (revision ) @@ -1,83 +1,0 @@ -c***************************************************************************** -c - subroutine suaviza ( x, n, ismooth, y ) -c -c x - input and return values -c y - auxiliary vector -c ismooth = 0 --> no smoothing is performed -c ismooth = 1 --> weak smoothing (5 points, centred weighted) -c ismooth = 2 --> normal smoothing (3 points, evenly weighted) -c ismooth = 3 --> strong smoothing (5 points, evenly weighted) - - -c malv august 1991 -c***************************************************************************** - - implicit none - - integer n, imax, imin, i, ismooth - real*8 x(n), y(n) -c***************************************************************************** - - imin=1 - imax=n - - if (ismooth.eq.0) then - - return - - elseif (ismooth.eq.1) then ! 5 points, with central weighting - - do i=imin,imax - if(i.eq.imin)then - y(i)=x(imin) - elseif(i.eq.imax)then - y(i)=x(imax-1)+(x(imax-1)-x(imax-3))/2.d0 - elseif(i.gt.(imin+1) .and. i.lt.(imax-1) )then - y(i) = ( x(i+2)/4.d0 + x(i+1)/2.d0 + 2.d0*x(i)/3.d0 + - 1 x(i-1)/2.d0 + x(i-2)/4.d0 )* 6.d0/13.d0 - else - y(i)=(x(i+1)/2.d0+x(i)+x(i-1)/2.d0)/2.d0 - end if - end do - - elseif (ismooth.eq.2) then ! 3 points, evenly spaced - - do i=imin,imax - if(i.eq.imin)then - y(i)=x(imin) - elseif(i.eq.imax)then - y(i)=x(imax-1)+(x(imax-1)-x(imax-3))/2.d0 - else - y(i) = ( x(i+1)+x(i)+x(i-1) )/3.d0 - end if - end do - - elseif (ismooth.eq.3) then ! 5 points, evenly spaced - - do i=imin,imax - if(i.eq.imin)then - y(i) = x(imin) - elseif(i.eq.(imin+1) .or. i.eq.(imax-1))then - y(i) = ( x(i+1)+x(i)+x(i-1) )/3.d0 - elseif(i.eq.imax)then - y(i) = ( x(imax-1) + x(imax-1) + x(imax-2) ) / 3.d0 - else - y(i) = ( x(i+2)+x(i+1)+x(i)+x(i-1)+x(i-2) )/5.d0 - end if - end do - - else - - write (*,*) ' Error in suaviza.f Wrong ismooth value.' - stop - - endif - -c rehago el cambio, para devolver x(i) - do i=imin,imax - x(i)=y(i) - end do - - return - end Index: trunk/LMDZ.MARS/libf/phymars/sypvmv.F =================================================================== --- trunk/LMDZ.MARS/libf/phymars/sypvmv.F (revision 496) +++ (revision ) @@ -1,17 +1,0 @@ -c *********************************************************************** - subroutine sypvmv(v,u,c,w,n) -c inputs: matriz diagonal c , vectores u,w -c output: vector v -c Operacion a realizar: v = u + c * w - -c jul 2011 malv+fgg -c *********************************************************************** - real*8 v(n),u(n),c(n,n),w(n) - integer n,i - do 1,i=2,n-1 - v(i)= u(i) + c(i,i) * w(i) - 1 continue - v(1) = 0.0d0 - v(n) = 0.0d0 - return - end Index: trunk/LMDZ.MARS/libf/phymars/sypvvv.F =================================================================== --- trunk/LMDZ.MARS/libf/phymars/sypvvv.F (revision 496) +++ (revision ) @@ -1,14 +1,0 @@ -c *********************************************************************** - subroutine sypvvv(a,b,c,d,n) -c a(i)=b(i)+c(i)*d(i) -c jul 2011 malv+fgg -c *********************************************************************** - real*8 a(n),b(n),c(n),d(n) - integer n,i - do 1,i=2,n-1 - a(i)= b(i) + c(i) * d(i) - 1 continue - a(1) = 0.0d0 - a(n) = 0.0d0 - return - end Index: trunk/LMDZ.MARS/libf/phymars/tcr_15um.h =================================================================== --- trunk/LMDZ.MARS/libf/phymars/tcr_15um.h (revision 496) +++ (revision ) @@ -1,92 +1,0 @@ -c**************************************************************************** -c -c tcr_15um.cmn -c -c Common blocks of coefficients and constants for NLTE CR -c (for the NLTE driver table) -c -c JAN 98 MALV Based on SOLAR10s mztv1.cmn -c MAR 2010 FGG Adaptation to GCM -c**************************************************************************** -c - integer irw_mztf,imu,ioverlap,nw,itt_cza,icls_mztf,nan -c - parameter (irw_mztf = 2) - parameter (imu = 1) - parameter (ioverlap = 0) - parameter (nw = 3) - parameter (itt_cza = 13) - parameter (icls_mztf = 5) - parameter (nan = 0) -c -c - integer iopt3, iopt19,iopt20, iopt21,iopt27,iopt26 -c - parameter (iopt3 = 1) - parameter (iopt19 = 2) - parameter (iopt20 = 2) - parameter (iopt21 = 1) - parameter (iopt27 = 1) - parameter (iopt26 = 2) -c -c - integer iopt41,iopt43, iopt6 -c - parameter (iopt6 = 2) - parameter (iopt41 = 2) - parameter (iopt43 = 2) -c -c - real tsurf_excess,Pbottom_atm,Ptop_atm -c - parameter (tsurf_excess = 0.) - parameter (Pbottom_atm = 2.e-5) - parameter (Ptop_atm = 5.e-12) -c -c - real*8 rf1,rf2desac,rf2iso,rf3,rf6 -c - parameter (rf1 = 1.d0) - parameter (rf2desac = 1.d0) - parameter (rf2iso = 1.d0) - parameter (rf3 = 1.d0) - parameter (rf6 = 1.d0) -c -c - real*8 rf7,rf19,rf20,rf21a,rf21b,rf21c -c - parameter (rf7 = 1.d0) - parameter (rf19 = 1.d0) - parameter (rf20 = 1.d0) - parameter (rf21a = 1.d0) - parameter (rf21b = 1.d0) - parameter (rf21c = 1.d0) -c -c - real*8 rf26,rf27f,rf27s,rf28,rf31,rf32,rf33a,rf33bc -c - parameter (rf26 = 1.d0) - parameter (rf27f = 1.d0) - parameter (rf27s = 1.d0) - parameter (rf28 = 1.d0) - parameter (rf31 = 1.d0) - parameter (rf32 = 1.d0) - parameter (rf33a = 1.d0) - parameter (rf33bc = 1.d0) -c -c - real*8 rf41,rf42,rf43,rf_hcl,rf44 -c - parameter (rf41 = 1.d0) - parameter (rf42 = 1.d0) - parameter (rf43 = 1.d0) - parameter (rf_hcl = 1.d0) - parameter (rf44 = 1.d0) -c -c - real*8 frac6,frac21,frac33 -c - parameter (frac6 = 1.d0) - parameter (frac21 = 1.d0) - parameter (frac33 = 1.d0) - Index: trunk/LMDZ.MARS/libf/phymars/tcrco2_subrut.F =================================================================== --- trunk/LMDZ.MARS/libf/phymars/tcrco2_subrut.F (revision 496) +++ (revision ) @@ -1,157 +1,0 @@ -c*********************************************************************** -c tcrco2_subrut.f -c -c jan 98 malv version for mz1d. copied from solar10/mz4sub.f -c jul 2011 malv+fgg adapted to LMD-MGCM -c*********************************************************************** - -************************************************************************ - - subroutine dinterconnection ( v, vt ) - -* input: vib. temp. from che*.for programs, vt(nl) -* output: test vibrational temp. for other che*.for, v(nl) -! iconex_smooth=1 ==> with smoothing -! iconex_smooth=0 ==> without smoothing -! iconex_tk=40 ==> with forced lte up to 40 km -! iconex_tk=20 ==> with forced lte up to 20 km -************************************************************************ - - implicit none - include 'nltedefs.h' - -c argumentos - real*8 vt(nl), v(nl) - -c local variables - integer i - -c ************* - - do i=1,nl - v(i) = vt(i) - end do - -! lo siguiente se utilizaba en solar10, pero es mejor introducirlo en -! la driver. por ahora no lo uso todavia. -! call fluctua(v,iconex_fluctua) -! call smooth_nl(v,iconex_smooth,nl) -! call forzar_tk(v,iconex_tk) - - return - end - -c*********************************************************************** - subroutine smooth_nl(y,nlx,nl) - -c returns smoothed y -c*********************************************************************** - - implicit none - -c arguments - integer nl ! Dimension of vectors - integer nlx ! i. =0 ==> no smoothing - ! =m ==> smoothing from point m up to nl - real*8 y(nl) ! o. is returned after smoothed - -c local variables and constants - integer i , nlmax - parameter ( nlmax=250 ) ! Llevarse esto al mz1d.par ! - real*8 x(nlmax) - -c *************** - - if (nlx.eq.0) return - - do i=nlx,nl - x(i)=y(i) - y(i)=0. - end do - - do i=nlx,nl - if(i.eq.nlx)then - y(i)=x(i) - elseif(i.eq.nl)then - y(i)=2.*y(i-1)-y(i-2) - else - y(i)=(x(i+1)/2.+x(i)+x(i-1)/2.)/2. - end if - end do - - return - end - -c*********************************************************************** - function planckdp(tp,xnu) -c returns the black body function at wavenumber xnu and temperature t. -c*********************************************************************** - - implicit none - - include 'nltedefs.h' - include 'nlte_data.h' -! common/datis/ pi, vlight, ee, hplanck, gamma, ab, -! @ n_avog, GG, R0, cte_sb, kboltzman, raddeg -! real*8 pi, vlight, ee, hplanck, gamma, ab, -! @ n_avog, GG, R0, cte_sb, kboltzman, raddeg - - real*8 planckdp - real*8 xnu - real tp - - planckdp = gamma*xnu**3.0 / exp( ee*xnu/dble(tp) ) - !erg cm-2.sr-1/cm-1. - - return - end -c*********************************************************************** - function planckdpdp(tp,xnu) -c returns the black body function at wavenumber xnu and temperature t. -c*********************************************************************** - - implicit none - - include 'nltedefs.h' - include 'nlte_data.h' -! common/datis/ pi, vlight, ee, hplanck, gamma, ab, -! @ n_avog, GG, R0, cte_sb, kboltzman, raddeg -! real*8 pi, vlight, ee, hplanck, gamma, ab, -! @ n_avog, GG, R0, cte_sb, kboltzman, raddeg - - real*8 planckdpdp - real*8 xnu - real*8 tp - - planckdpdp = gamma*xnu**3.0 / exp( ee*xnu/dble(tp) ) - !erg cm-2.sr-1/cm-1. - - return - end -c **************************************************************** - function bandid (ib) -c returns the 2 character code of the band -c **************************************************************** - implicit none - - integer ib - character*2 bandid - -132 format(i2) -! encode (2,132,bandid) ib - write ( bandid, 132) ib - - if ( ib .eq. 1 ) bandid = '01' - if ( ib .eq. 2 ) bandid = '02' - if ( ib .eq. 3 ) bandid = '03' - if ( ib .eq. 4 ) bandid = '04' - if ( ib .eq. 5 ) bandid = '05' - if ( ib .eq. 6 ) bandid = '06' - if ( ib .eq. 7 ) bandid = '07' - if ( ib .eq. 8 ) bandid = '08' - if ( ib .eq. 9 ) bandid = '09' - if ( ib .eq. 0 ) bandid = '00' - -c end - return - end Index: trunk/LMDZ.MARS/libf/phymars/trucodiag.F =================================================================== --- trunk/LMDZ.MARS/libf/phymars/trucodiag.F (revision 496) +++ (revision ) @@ -1,28 +1,0 @@ -c *********************************************************************** - subroutine trucodiag(a,b,c,d,e,n) -c inputs: matrices b,c,d,e -c output: matriz diagonal a -c Operacion a realizar: a = b * c^(-1) * d + e -c La matriz c va a ser invertida -c Todas las matrices de entrada son diagonales excepto b -c Aprovechamos esa condicion para invertir c, acelerar el calculo, y -c ademas, para forzar que a sea diagonal -c jul 2011 malv+fgg -c *********************************************************************** - real*8 a(n,n),b(n,n),c(n,n),d(n,n),e(n,n), sum - integer n,i,j,k - do 1,i=2,n-1 - sum=0.0d0 - do 2,j=2,n-1 - sum=sum+ (b(i,j)) * (d(j,j)/c(j,j)) - 2 continue - a(i,i) = sum + e(i,i) - 1 continue - do k=1,n - a(n,k) = 0.0d0 - a(1,k) = 0.0d0 - a(k,1) = 0.0d0 - a(k,n) = 0.0d0 - end do - return - end Index: trunk/LMDZ.MARS/libf/phymars/trucommv.F =================================================================== --- trunk/LMDZ.MARS/libf/phymars/trucommv.F (revision 496) +++ (revision ) @@ -1,23 +1,0 @@ -c *********************************************************************** - subroutine trucommvv(v,b,c,u,w,n) -c inputs: matrices b,c , vectores u,w -c output: vector v -c Operacion a realizar: v = b * c^(-1) * u + w -c La matriz c va a ser invertida -c c es diagonal, b no -c Aprovechamos esa condicion para invertir c, y acelerar el calculo -c jul 2011 malv+fgg -c *********************************************************************** - real*8 v(n),b(n,n),c(n,n),u(n),w(n), sum - integer n,i,j,k - do 1,i=2,n-1 - sum=0.0d0 - do 2,j=2,n-1 - sum=sum+ (b(i,j)) * (u(j)/c(j,j)) - 2 continue - v(i) = sum + w(i) - 1 continue - v(1) = 0.d0 - v(n) = 0.d0 - return - end