[cig-commits] r5080 - in geodyn/3D: . MoSST MoSST/trunk
wei at geodynamics.org
wei at geodynamics.org
Mon Oct 23 13:50:23 PDT 2006
Author: wei
Date: 2006-10-23 13:50:23 -0700 (Mon, 23 Oct 2006)
New Revision: 5080
Added:
geodyn/3D/MoSST/
geodyn/3D/MoSST/branches/
geodyn/3D/MoSST/tags/
geodyn/3D/MoSST/trunk/
geodyn/3D/MoSST/trunk/bcs.f
geodyn/3D/MoSST/trunk/evolutions.f
geodyn/3D/MoSST/trunk/forces.f
geodyn/3D/MoSST/trunk/matrices.f
geodyn/3D/MoSST/trunk/miscs.f
geodyn/3D/MoSST/trunk/mod_anomaly.f
geodyn/3D/MoSST/trunk/mod_artdis.f
geodyn/3D/MoSST/trunk/mod_dataio.f
geodyn/3D/MoSST/trunk/mod_fields.f
geodyn/3D/MoSST/trunk/mod_matrices.f
geodyn/3D/MoSST/trunk/mod_params.f
geodyn/3D/MoSST/trunk/mosst_cig.f
geodyn/3D/MoSST/trunk/parameter.data
geodyn/3D/MoSST/trunk/params_io.f
geodyn/3D/MoSST/trunk/readme
geodyn/3D/MoSST/trunk/solvers.f
geodyn/3D/MoSST/trunk/time_integ.f
Log:
initial import of the MoSST code.
Added: geodyn/3D/MoSST/trunk/bcs.f
===================================================================
--- geodyn/3D/MoSST/trunk/bcs.f 2006-10-23 16:55:10 UTC (rev 5079)
+++ geodyn/3D/MoSST/trunk/bcs.f 2006-10-23 20:50:23 UTC (rev 5080)
@@ -0,0 +1,292 @@
+c
+c These group of subroutines provide inhomogeneous boundary
+c conditions arising from finitely conducting D"-layer and
+c from CMB topography.
+c The subroutines are running on Sun worksations with Sun
+c Performance Library.
+c W.Kuang 08/99
+c
+
+*************************************************************************
+*************************************************************************
+
+ subroutine bd_mag(boundi,boundm)
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+c This subroutine evaluates the boundary conditions at the inner
+c core boundary and the core-mantle boundary with given fields
+c (OMGI,OMGM,COUA,COUB,COVA,COVB,COB)
+c
+c-----------------------------------------------------------------------
+c
+c Notation explanation:
+c
+c (sb,dsv,sw): the spectral coefficients at radial
+c collocation points r_i;
+c (vth,vph): the velocity components in physical space;
+c (br): the radial magnetic field in physical space;
+c
+c (boundi): the boundary conditions at r_{io};
+c (boundm): the boundary conditions at r = 1;
+c
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ use mod_dimparam
+ use mod_sysparam
+ use mod_optparam
+
+ use mod_parity
+ use mod_radgeom
+ use mod_sphgeom
+
+ use mod_vfield
+ use mod_bfield
+ use mod_rotation
+
+ implicit none
+
+ complex (kind=8), dimension(0:Lmax_m,0:mmax_m) :: boundi,boundm
+
+ integer i,j,k,L,m,n
+ real (kind=8) c1,c2
+ complex (kind=8) zi1,zi2,zi3,zi4,ui,uim,zeros
+
+ real (kind=8), dimension(npmax,ntmax) :: br,bth,bph,vth,vph,
+ & tmpr1,tmpr2
+
+ complex (kind=8), dimension(0:Lmax1,0:mmax) :: dsv,sw,sb
+ complex (kind=8), dimension(0:Lmaxa,0:mmaxa) :: tmpc1,
+ & tmpc2,tmpc3
+
+C
+C SUBROUTINE STARTS HERE
+C
+
+ ui = cmplx(0.0,1.0)
+ zeros = cmplx(0.0,0.0)
+
+C
+C-------Initializing the boundary conditions and the velocity fields
+C
+
+ boundi = zeros
+ boundm = zeros
+
+ if (kicbv.eq.1 .and. kcmbv.eq.1) then
+ return
+ endif
+
+ if (kicbb.le.1 .and. kcmbb.le.1) then
+ return
+ endif
+
+ call group
+
+C
+C-------Spectral coefficients of horizontal velocities in
+C-------the inner core (zi1,zi2,zi3,zi4)
+C
+
+ zi1 = -ui*rio**2*sqrt(2.0*pi/3.0)*conjg(omgih)
+ zi2 = rio**2*sqrt(2.0*pi/15.0)*conjg(omgih)
+ zi3 = 4.0*rio**2*sqrt(pi)*omgiz/3.0
+ zi4 = -4.0*rio**2*sqrt(pi/5.0)*omgiz/3.0
+
+C
+C-------The boundary conditions at the ICB
+C
+
+ if (kicbb.eq.2 .and. kicbv.ne.1) then
+
+c obtaining (b_l^m,dv_l^m/dr,w_l^m) at r=r_io
+
+ sb = zeros
+ dsv = zeros
+ sw = zeros
+
+ do L = 1,Lmax_m
+ sb(L,0) = 0.5*(cob(nmbic-1,L,0)+cob(nmbic+1,L,0))
+ enddo
+ do m = 1,mmax_m
+ do L = m,Lmax_m
+ sb(L,m) = 0.5*(cob(nmbic-1,L,m)+cob(nmbic+1,L,m))
+ enddo
+ enddo
+
+ do n = 0,nmax_v
+ do L = 1,Lmax_v
+ dsv(L,0) = dsv(L,0)+dch1(n,0)*vlm(n,L,0)
+ sw(L,0) = sw(L,0)+cheb(n,0)*wlm(n,L,0)
+ enddo
+ do m = 1,mmax_v
+ do L = m,Lmax_v
+ dsv(L,m) = dsv(L,m)+dch1(n,0)*vlm(n,L,m)
+ sw(L,m) = sw(L,m)+cheb(n,0)*wlm(n,L,m)
+ enddo
+ enddo
+ enddo
+
+c obtaining {r^2b_r, r sin(th) [v_th], r sin(th) [v_ph]}
+
+ tmpc1= zeros
+ do m = 0,mmax
+ tmpc1(m:Lmax,m) = LL(m:Lmax)*sb(m:Lmax,m)
+ enddo
+
+ call izfspht(tmpc1,aslg,table,Lmaxa,mmaxa,ntmax,
+ & npmax,br)
+
+ tmpc1= zeros
+ tmpc2= zeros
+ do m = 0,mmax
+ uim = cmplx(0.0,1.0*m)
+ do L= m+1,Lmax
+ tmpc1(L,m) = uim*sw(L,m)+clm(L,m,1)*dsv(L-1,m)
+ & -clm(L,m,2)*dsv(L+1,m)
+ tmpc2(L,m) = uim*dsv(L,m)-clm(L,m,1)*sw(L-1,m)
+ & +clm(L,m,2)*sw(L+1,m)
+ enddo
+ tmpc1(m,m) = uim*sw(m,m)-clm(m,m,2)*dsv(m+1,m)
+ tmpc2(m,m) = uim*dsv(m,m)+clm(m,m,2)*sw(m+1,m)
+ enddo
+ tmpc1(1,1) = tmpc1(1,1)-zi1
+ tmpc2(2,1) = tmpc2(2,1)-zi2
+ tmpc2(0,0) = tmpc2(0,0)-zi3
+ tmpc2(2,0) = tmpc2(2,0)-zi4
+
+ call izfspht(tmpc1,aslg,table,Lmaxa,mmaxa,ntmax,
+ & npmax,vth)
+ call izfspht(tmpc2,aslg,table,Lmaxa,mmaxa,ntmax,
+ & npmax,vph)
+
+c evaluating the inhomogeneous boundary conditions at r=r_io
+
+ do k = 1,ntmax
+ c1= 1.0/(rio*sins(k))**2
+ tmpr1(:,k) = c1*br(:,k)*vth(:,k)
+ tmpr2(:,k) = c1*br(:,k)*vph(:,k)
+ enddo
+ call zfspht(tmpr1,aslg,gauwt,table,Lmaxa,mmaxa,ntmax,
+ & npmax,tmpc1)
+ call zfspht(tmpr2,aslg,gauwt,table,Lmaxa,mmaxa,ntmax,
+ & npmax,tmpc2)
+
+ tmpc3= zeros
+ do m = 0,mmax
+ uim = cmplx(0.0,1.0*m)
+ do L= m+1,Lmax
+ tmpc3(L,m) = uim*tmpc1(L,m)-clm(L,m,3)*
+ & tmpc2(L-1,m)+clm(L,m,4)*tmpc2(L+1,m)
+ enddo
+ tmpc3(m,m) = uim*tmpc1(m,m)+clm(m,m,4)*tmpc2(m+1,m)
+ enddo
+ do L = 1,Lmax_m
+ boundi(L,0) = tmpc3(L,0)/(1.0*LL(L))
+ enddo
+ do m = 1,mmax_m
+ do L = m,Lmax_m
+ boundi(L,m) = tmpc3(L,m)/(1.0*LL(L))
+ enddo
+ enddo
+
+ endif
+
+C
+C-------The boundary conditions at the CMB
+C
+
+ if (kcmbb.eq.2 .and. kcmbv.ne.1) then
+
+c obtaining (b_l^m,dv_l^m/dr,w_l^m) at r=1
+
+ sb = zeros
+ dsv = zeros
+ sw = zeros
+
+ do L = 1,Lmax_m
+ sb(L,0) = cob(nmx3+nmbic-1,L,0)
+ enddo
+ do m = 1,mmax_m
+ do L = m,Lmax_m
+ sb(L,m) = cob(nmx3+nmbic-1,L,m)
+ enddo
+ enddo
+
+ do n = 0,nmax_v
+ do L = 1,Lmax_v
+ dsv(L,0) = dsv(L,0)+dch1(n,nmaxo)*vlm(n,L,0)
+ sw(L,0) = sw(L,0)+cheb(n,nmaxo)*wlm(n,L,0)
+ enddo
+ do m = 1,mmax_v
+ do L = m,Lmax_v
+ dsv(L,m) = dsv(L,m)+dch1(n,nmaxo)*vlm(n,L,m)
+ sw(L,m) = sw(L,m)+cheb(n,nmaxo)*wlm(n,L,m)
+ enddo
+ enddo
+ enddo
+
+c obtaining {r^2b_r, r sin(th) [v_th], r sin(th) [v_ph]}
+
+ tmpc1= zeros
+ do m = 0,mmax
+ tmpc1(m:Lmax,m) = LL(m:Lmax)*sb(m:Lmax,m)
+ enddo
+
+ call izfspht(tmpc1,aslg,table,Lmaxa,mmaxa,ntmax,
+ & npmax,br)
+
+ tmpc1= zeros
+ tmpc2= zeros
+ do m = 0,mmax
+ uim = cmplx(0.0,1.0*m)
+ do L= m+1,Lmax
+ tmpc1(L,m) = uim*sw(L,m)+clm(L,m,1)*dsv(L-1,m)
+ & -clm(L,m,2)*dsv(L+1,m)
+ tmpc2(L,m) = uim*dsv(L,m)-clm(L,m,1)*sw(L-1,m)
+ & +clm(L,m,2)*sw(L+1,m)
+ enddo
+ tmpc1(m,m) = uim*sw(m,m)-clm(m,m,2)*dsv(m+1,m)
+ tmpc2(m,m) = uim*dsv(m,m)+clm(m,m,2)*sw(m+1,m)
+ enddo
+
+ call izfspht(tmpc1,aslg,table,Lmaxa,mmaxa,ntmax,
+ & npmax,vth)
+ call izfspht(tmpc2,aslg,table,Lmaxa,mmaxa,ntmax,
+ & npmax,vph)
+
+c evaluating the inhomogeneous boundary conditions
+
+ do k = 1,ntmax
+ c1= 1.0/sins(k)**2
+ tmpr1(:,k) = c1*br(:,k)*vth(:,k)
+ tmpr2(:,k) = c1*br(:,k)*vph(:,k)
+ enddo
+ call zfspht(tmpr1,aslg,gauwt,table,Lmaxa,mmaxa,ntmax,
+ & npmax,tmpc1)
+ call zfspht(tmpr2,aslg,gauwt,table,Lmaxa,mmaxa,ntmax,
+ & npmax,tmpc2)
+
+ tmpc3 = zeros
+ do m = 0,mmax
+ uim = cmplx(0.0,1.0*m)
+ do L = m+1,Lmax
+ tmpc3(L,m) = uim*tmpc1(L,m)-clm(L,m,3)*
+ & tmpc2(L-1,m)+clm(L,m,4)*tmpc2(L+1,m)
+ enddo
+ tmpc3(m,m) = uim*tmpc1(m,m)+clm(m,m,4)*tmpc2(m+1,m)
+ enddo
+
+ do L = 1,Lmax_m
+ boundm(L,0) = tmpc3(L,0)/(1.0*LL(L))
+ enddo
+ do m = 1,mmax_m
+ do L = m,Lmax_m
+ boundm(L,m) = tmpc3(L,m)/(1.0*LL(L))
+ enddo
+ enddo
+
+ endif
+
+ return
+ end
+
+
Property changes on: geodyn/3D/MoSST/trunk/bcs.f
___________________________________________________________________
Name: svn:executable
+
Added: geodyn/3D/MoSST/trunk/evolutions.f
===================================================================
--- geodyn/3D/MoSST/trunk/evolutions.f 2006-10-23 16:55:10 UTC (rev 5079)
+++ geodyn/3D/MoSST/trunk/evolutions.f 2006-10-23 20:50:23 UTC (rev 5080)
@@ -0,0 +1,907 @@
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+! This is the collection of subroutines that describe time
+! evolution processes in dynamo modeling.
+!
+! W. Kuang, 09/2002
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ subroutine evol_abam
+c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c +
+c This subroutine evaluates the time variation of the flow. The +
+c method is the combination of a 2nd order Runger-Kutter method +
+c and a Adams family predictor(A-B)-corrector(A-M) method. +
+c +
+c-----------------------------------------------------------------------+
+c +
+c The order of calculation: +
+c +
+c (1) updating the asymmetric velocity (COVA,COVB) by the new +
+c magnetic field (COB,COJ) and new thermal field (COT,COC); +
+c (2) obtaining the nonlinear forcing (FUA,FUB,FB,FJ,FT,FC) for +
+c the fields (COUA,COUB,COB,COJ,COT,COC); +
+c (3) Updating (COUA,COUB,COB,COJ,COT,COC) by +
+c (a) a second-order Runger-Kutter method if the time step +
+c "Dt" changes (i.e. the CFL condition number changes); +
+c (b) or a third-order Adams-Bashford/Adams-Molten method +
+c if "Dt" remains the same (i.e. the CFL condition +
+c number is unaltered); +
+c (4) Testing CFL condition; +
+c (5) repeate the above procedures; +
+c +
+c-----------------------------------------------------------------------+
+c +
+c (gzi,gzim1,gzim2): the axial torque acting on the inner core; +
+c (ghi,ghim1,ghim2): the horizontal torque on the inner core; +
+c (gzm,gzmm1,gzmm2): the axial torque acting on the mantle; +
+c (ghm,ghmm1,ghmm2): the horizontal torque acting on the mantle; +
+c (fua,fuam1,fuam2): the nonlinear force for axisymmetric +
+c velocity COUA; +
+c (fub,fubm1,fubm2): the nonlinear force for axisymmetric +
+c velocity COUB; +
+c (fb,fbm1,fbm2): the nonlinear force for poloidal +
+c magnetic field COB; +
+c (fj,fjm1,fjm2): the nonlinear force for toroidal +
+c magnetic field COJ; +
+c (ft,ftm1,ftm2): the nonlinear force for temperature COT; +
+c (fc,fcm1,fcm2): the nonlinear force for concentration COC; +
+c +
+c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ use mod_dimparam
+ use mod_sysparam
+ use mod_numparam
+ use mod_optparam
+
+ use mod_radgeom
+ use mod_artdis
+
+ use mod_rotation
+
+ use mod_vmatrix
+ use mod_bmatrix
+ use mod_tmatrix
+
+ use mod_cmbheat
+
+ use mod_dataio
+
+! use mod_assim
+
+ implicit none
+
+ integer k,nd
+ integer unit_diag1,unit_diag2,unit_rec,unit_time
+ integer ndimg1,ndimg2,ndimg3,ndimg4
+ integer i,j,nt1,nabam,nrunger
+ real (kind=8) dtmin,dtmax,tt,ttf,ttd
+
+ real (kind=8) gzi,gzim1,gzim2,gzm,gzmm1,gzmm2
+
+ complex (kind=8) ghi,ghim1,ghim2,ghm,ghmm1,ghmm2
+
+ complex (kind=8), dimension(nmx2) :: fua,fuam1,fuam2,fub,
+ & fubm1,fubm2
+ complex (kind=8), dimension(nmx6,0:Lmax_m,0:mmax_m) :: fb,fbm1,
+ & fbm2,fj,fjm1,fjm2
+ complex (kind=8), dimension(nmx3,0:Lmax_t,0:mmax_t) :: ft,ftm1,
+ & ftm2
+
+ real (kind=8), allocatable :: delt_g(:,:,:,:), drhomm(:,:,:)
+
+C
+C SUBROUTINE STARTS HERE
+C
+
+ ndimg1 = 0
+ ndimg2 = 0
+ ndimg3 = 0
+ ndimg4 = 0
+
+ tt = tt0
+ ttf = 0.0
+ ttd = 0.0
+ j = 0
+ nd = 0
+
+C
+C ESTABLISHING OUTPUT CHANNELS FOR DIAGNOSTICS AND RECORDS
+C
+
+ call output_files(unit_diag1,unit_diag2,unit_rec,unit_time)
+
+C
+C Modeling parameters output
+C
+
+ call diagout(unit_diag1,unit_diag2,tt,nd,0)
+ call recout(unit_rec,0)
+
+C
+C INITIALIZING THE FORCING
+C
+
+ gzi = 0.0
+ gzim1 = 0.0
+ gzim2 = 0.0
+ gzm = 0.0
+ gzmm1 = 0.0
+ gzmm2 = 0.0
+
+ ghi = 0.0
+ ghim1 = 0.0
+ ghim2 = 0.0
+ ghm = 0.0
+ ghmm1 = 0.0
+ ghmm2 = 0.0
+
+ fua = 0.0
+ fuam1 = 0.0
+ fuam2 = 0.0
+ fub = 0.0
+ fubm1 = 0.0
+ fubm2 = 0.0
+ fb = 0.0
+ fbm1 = 0.0
+ fbm2 = 0.0
+ fj = 0.0
+ fjm1 = 0.0
+ fjm2 = 0.0
+ ft = 0.0
+ ftm1 = 0.0
+ ftm2 = 0.0
+
+!
+! Options of including mantle density anomaly effect
+!
+
+C
+C OBTAINING ASYMMETRIC VELOCITY (COVA,COVB) AT T = T_0 AND THE
+C FORCE (GZI,GZM,GHI,GHM,FUA,FUB,FB,FJ,FT) AT T_0
+C
+
+ call nonlinear(ndimg1,ndimg2,ndimg3,ndimg4,delt_g,drhomm,
+ & gzi,gzm,ghi,ghm,fua,fub,fb,fj,ft)
+
+ nt1 = 1
+
+C
+C UPDATING THE STATE VIA 2ND ORDER Runger-Kutter METHOD
+C
+
+ 10 continue
+
+ nabam = 0
+
+ do i = nt1,ntt
+
+c----------Updating (OMGI,OMGM,COUA,COUB,COB,COJ,COT)
+
+c call rungkt3(gzi,gzm,ghi,ghm,fua,fub,fb,fj,ft,
+c & delt_g,drhomm,ndimg1,ndimg2,ndimg3,
+c & ndimg4)
+ call rungkt2(gzi,gzm,ghi,ghm,fua,fub,fb,fj,ft,
+ & delt_g,drhomm,ndimg1,ndimg2,ndimg3,
+ & ndimg4)
+
+c----------Updating the nonlinear forcing at t_[k-1], t_[k-2]
+
+ gzim2 = gzim1
+ gzmm2 = gzmm1
+ ghim2 = ghim1
+ ghmm2 = ghmm1
+ fuam2 = fuam1
+ fubm2 = fubm1
+ fbm2 = fbm1
+ fjm2 = fjm1
+ ftm2 = ftm1
+
+ gzim1 = gzi
+ gzmm1 = gzm
+ ghim1 = ghi
+ ghmm1 = ghm
+ fuam1 = fua
+ fubm1 = fub
+ fbm1 = fb
+ fjm1 = fj
+ ftm1 = ft
+
+c----------Updating (COVA,COVB) and the nonlinear forcing at t_[k]
+
+ call nonlinear(ndimg1,ndimg2,ndimg3,ndimg4,delt_g,
+ & drhomm,gzi,gzm,ghi,ghm,fua,fub,fb,fj,ft)
+
+c----------Updating the time
+
+ tt = tt+deltt
+ ttf = ttf+deltt
+ ttd = ttd+deltt
+
+ nt1 = i+1
+ nabam = nabam+1
+
+c----------data output
+
+ if (ttd.ge.toutd-1.e-9 .and. ttf.lt.toutf-1.e-9) then
+ call diagout(unit_diag1,unit_diag2,tt,nd,1)
+ ttd = 0.0
+ nd = nd+1
+ endif
+
+ if (ttf.ge.toutf-1.e-9 .or. i.gt.ntt-1) then
+ call diagout(unit_diag1,unit_diag2,tt,nd,2)
+ call recout(unit_rec,1)
+ call data_out1
+ ttf = 0.0
+ ttd = 0.0
+ nd = 0
+ fileno_out= fileno_out+1
+ endif
+
+c----------Testing the condition for AB-AM method
+
+ if (nabam .gt. 1.5) go to 11
+
+ enddo
+
+C
+C UPDATING THE STATE VIA 3RD ORDER AB-AM METHOD
+C
+
+ 11 continue
+
+ nrunger = 0
+
+ do i = nt1,ntt
+
+c----------Updating (OMGI,OMGM,COUA,COUB,COB,COJ,COT)
+
+ call abam3(gzi,gzim1,gzim2,gzm,gzmm1,gzmm2,ghi,ghim1,
+ & ghim2,ghm,ghmm1,ghmm2,fua,fuam1,fuam2,fub,
+ & fubm1,fubm2,fb,fbm1,fbm2,fj,fjm1,fjm2,ft,
+ & ftm1,ftm2,delt_g,drhomm,ndimg1,ndimg2,
+ & ndimg3,ndimg4)
+
+c----------Updating the nonlinear forcing at t_[k-1], t_[k-2]
+
+ gzim2 = gzim1
+ gzmm2 = gzmm1
+ ghim2 = ghim1
+ ghmm2 = ghmm1
+ fuam2 = fuam1
+ fubm2 = fubm1
+ fbm2 = fbm1
+ fjm2 = fjm1
+ ftm2 = ftm1
+
+ gzim1 = gzi
+ gzmm1 = gzm
+ ghim1 = ghi
+ ghmm1 = ghm
+ fuam1 = fua
+ fubm1 = fub
+ fbm1 = fb
+ fjm1 = fj
+ ftm1 = ft
+
+c----------Updating (COVA,COVB) and the nonlinear forcing at t_[k]
+
+ call nonlinear(ndimg1,ndimg2,ndimg3,ndimg4,delt_g,
+ & drhomm,gzi,gzm,ghi,ghm,fua,fub,fb,fj,ft)
+
+c----------Updating the time
+
+ tt = tt+deltt
+ ttf = ttf+deltt
+ ttd = ttd+deltt
+
+ nt1 = i+1
+
+c----------Updating CFL condition
+
+ j = j+1
+ if (j.ge.ncfl .or. i.gt.ntt-1) then
+ dtmin = cflmin*cflno
+ dtmax = cflmax*cflno
+ if (deltt.lt.dtmin .or. deltt.gt.dtmax) then
+cts1 deltt = 0.5*(dtmin+dtmax)
+cts2 deltt = 0.25*(dtmin+dtmax)+0.5*deltt
+ itrung = 0
+ call vmatrixu
+ call bmatrix
+ call tmatrix
+ nrunger= 1
+ call timeout(unit_time,tt)
+ endif
+ j = 0
+ if (deltt .lt. 1.e-15) then
+ call diagout(unit_diag1,unit_diag2,tt,nd,2)
+ call recout(unit_rec,1)
+ call data_out1
+ stop
+ endif
+ endif
+
+c----------Data output
+
+ if (ttd.ge.toutd-1.e-9 .and. ttf.lt.toutf-1.e-9) then
+ call diagout(unit_diag1,unit_diag2,tt,nd,1)
+ ttd = 0.0
+ nd = nd+1
+ endif
+
+
+ if (ttf.ge.toutf-1.e-9 .or. i.gt.ntt-1) then
+ call diagout(unit_diag1,unit_diag2,tt,nd,2)
+ call recout(unit_rec,1)
+ call data_out1
+ ttf = 0.0
+ ttd = 0.0
+ nd = 0
+ fileno_out= fileno_out+1
+ endif
+
+c----------Testing the condition for Runger-Kutter method
+
+ if (nrunger .gt. 0) go to 10
+
+ enddo
+
+ return
+ end
+
+*************************************************************************
+*************************************************************************
+
+ subroutine evol_rk
+c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c +
+c This subroutine evaluates the time variation of the flow with +
+c the third order Runger-Kutter method. +
+c +
+c-----------------------------------------------------------------------+
+c +
+c The order of calculation: +
+c +
+c (1) updating the asymmetric velocity (COVA,COVB) by the new +
+c magnetic field (COB,COJ) and new thermal field (COT,COC); +
+c (2) obtaining the nonlinear forcing (FUA,FUB,FB,FJ,FT,FC) for +
+c the fields (COUA,COUB,COB,COJ,COT,COC); +
+c (3) Updating (COUA,COUB,COB,COJ,COT,COC) by +
+c a third-order Runger-Kutter method. +
+c (4) Testing CFL condition; +
+c (5) repeate the above procedures; +
+c +
+c-----------------------------------------------------------------------+
+c +
+c gzi: the axial torque acting on the inner core; +
+c ghi: the horizontal torque on the inner core; +
+c gzm: the axial torque acting on the mantle; +
+c ghm: the horizontal torque acting on the mantle; +
+c fua: the nonlinear force for axisymmetric velocity COUA; +
+c fub: the nonlinear force for axisymmetric velocity COUB; +
+c fb: the nonlinear force for poloidal magnetic field COB; +
+c fj: the nonlinear force for toroidal magnetic field COJ; +
+c ft: the nonlinear force for temperature COT; +
+c fc: the nonlinear force for concentration COC; +
+c +
+c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ use mod_dimparam
+ use mod_sysparam
+ use mod_numparam
+ use mod_optparam
+
+ use mod_radgeom
+ use mod_artdis
+
+ use mod_rotation
+
+ use mod_vmatrix
+ use mod_bmatrix
+ use mod_tmatrix
+
+ use mod_cmbheat
+
+ use mod_dataio
+
+ implicit none
+
+ integer i,j,k,nd
+ integer unit_diag1,unit_diag2,unit_rec,unit_time
+ integer ndimg1,ndimg2,ndimg3,ndimg4
+ real (kind=8) dtmin,dtmax,tt,ttf,ttd,amv,amb,amt,elb,elv
+
+ real (kind=8) gzi,gzm
+
+ complex (kind=8) ghi,ghm
+
+ complex (kind=8), dimension(nmx2) :: fua,fub
+ complex (kind=8), dimension(nmx6,0:Lmax_m,0:mmax_m) :: fb,fj
+ complex (kind=8) ft(nmx3,0:Lmax_t,0:mmax_t)
+
+ real (kind=8), allocatable :: delt_g(:,:,:,:), drhomm(:,:,:)
+
+C
+C SUBROUTINE STARTS HERE
+C
+
+ tt = tt0
+ ttf = 0.0
+ ttd = 0.0
+ j = 0
+ nd = 0
+
+C
+C ESTABLISHING OUTPUT CHANNELS FOR DIAGNOSTICS AND RECORDS
+C
+
+ call output_files(unit_diag1,unit_diag2,unit_rec,unit_time)
+
+C
+C Modeling parameters output
+C
+
+ call diagout(unit_diag1,unit_diag2,tt,nd,0)
+ call recout(unit_rec,0)
+
+C
+C INITIALIZING THE FORCING
+C
+
+ gzi = 0.0
+ gzm = 0.0
+ ghi = 0.0
+ ghm = 0.0
+
+ fua = 0.0
+ fub = 0.0
+ fb = 0.0
+ fj = 0.0
+ ft = 0.0
+
+!
+! Options of including mantle density anomaly effect
+!
+
+C
+C OBTAINING ASYMMETRIC VELOCITY (COVA,COVB) AT T = T_0 AND THE
+C FORCE (GZI,GZM,GHI,GHM,FUA,FUB,FB,FJ,FT) AT T_0
+C
+
+ call nonlinear(ndimg1,ndimg2,ndimg3,ndimg4,delt_g,drhomm,
+ & gzi,gzm,ghi,ghm,fua,fub,fb,fj,ft)
+
+C
+C UPDATING THE STATE VIA 3RD ORDER Runger-Kutter METHOD
+C
+
+ do i = 1,ntt
+
+c----------Updating (OMGI,OMGM,COUA,COUB,COB,COJ,COT)
+
+c call rungkt3(gzi,gzm,ghi,ghm,fua,fub,fb,fj,ft,
+c & delt_g,drhomm,ndimg1,ndimg2,ndimg3,
+c & ndimg4)
+ call rungkt2(gzi,gzm,ghi,ghm,fua,fub,fb,fj,ft,
+ & delt_g,drhomm,ndimg1,ndimg2,ndimg3,
+ & ndimg4)
+
+c----------Updating (COVA,COVB) and the nonlinear forcing at t_[k]
+
+ call nonlinear(ndimg1,ndimg2,ndimg3,ndimg4,delt_g,
+ & drhomm,gzi,gzm,ghi,ghm,fua,fub,fb,fj,ft)
+
+c----------Updating the time
+
+ tt = tt+deltt
+ ttf = ttf+deltt
+ ttd = ttd+deltt
+
+c----------Updating CFL condition
+
+ j = j+1
+ if (j.ge.ncfl .or. i.gt.ntt-1) then
+ dtmin = cflmin*cflno
+ dtmax = cflmax*cflno
+ if (deltt.lt.dtmin .or. deltt.gt.dtmax) then
+cts1 deltt = 0.5*(dtmin+dtmax)
+cts2 deltt = 0.25*(dtmin+dtmax)+0.5*deltt
+ itrung = 2
+ call vmatrixu
+ call bmatrix
+ call tmatrix
+ call timeout(unit_time,tt)
+ endif
+ j = 0
+ if (deltt .lt. 1.e-15) then
+ call diagout(unit_diag1,unit_diag2,tt,nd,2)
+ call recout(unit_rec,1)
+ call data_out1
+ stop
+ endif
+ endif
+
+c----------data output
+
+ if (ttd.ge.toutd-1.e-9 .and. ttf.lt.toutf-1.e-9) then
+ call diagout(unit_diag1,unit_diag2,tt,nd,1)
+ ttd = 0.0
+ nd = nd+1
+ endif
+
+ if (ttf.ge.toutf-1.e-9 .or. i.gt.ntt-1) then
+ call diagout(unit_diag1,unit_diag2,tt,nd,2)
+ call recout(unit_rec,1)
+ call data_out1
+ ttf = 0.0
+ ttd = 0.0
+ nd = 0
+ fileno_out= fileno_out+1
+ endif
+
+ enddo
+
+ return
+ end
+
+*************************************************************************
+*************************************************************************
+
+ subroutine evol_abam_new
+c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c +
+c This subroutine evaluates the time variation of the flow via +
+c the combination of a second order Runger-Kutter method and an +
+c Adams family predictor(A-B)-corrector(A-M) method. The time +
+c step for the RK method is half of the normal time step to +
+c accomodate smaller stability regime of the algorithm. +
+c +
+c-----------------------------------------------------------------------+
+c +
+c The order of calculation: +
+c +
+c (1) updating the asymmetric velocity (COVA,COVB) by the new +
+c magnetic field (COB,COJ) and new thermal field (COT,COC); +
+c (2) obtaining the nonlinear forcing (FUA,FUB,FB,FJ,FT,FC) for +
+c the fields (COUA,COUB,COB,COJ,COT,COC); +
+c (3) Updating (COUA,COUB,COB,COJ,COT,COC) by +
+c (a) a second-order Runger-Kutter method if the time step +
+c "Dt" changes (i.e. the CFL condition number changes); +
+c (b) or a third-order Adams-Bashford/Adams-Molten method +
+c if "Dt" remains the same (i.e. the CFL condition +
+c number is unaltered); +
+c (4) Testing CFL condition; +
+c (5) repeate the above procedures; +
+c +
+c-----------------------------------------------------------------------+
+c +
+c (gzi,gzim1,gzim2): the axial torque acting on the inner core; +
+c (ghi,ghim1,ghim2): the horizontal torque on the inner core; +
+c (gzm,gzmm1,gzmm2): the axial torque acting on the mantle; +
+c (ghm,ghmm1,ghmm2): the horizontal torque acting on the mantle; +
+c (fua,fuam1,fuam2): the nonlinear force for axisymmetric +
+c velocity COUA; +
+c (fub,fubm1,fubm2): the nonlinear force for axisymmetric +
+c velocity COUB; +
+c (fb,fbm1,fbm2): the nonlinear force for poloidal +
+c magnetic field COB; +
+c (fj,fjm1,fjm2): the nonlinear force for toroidal +
+c magnetic field COJ; +
+c (ft,ftm1,ftm2): the nonlinear force for temperature COT; +
+c (fc,fcm1,fcm2): the nonlinear force for concentration COC; +
+c +
+c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+!
+! The difference in this subroutine is that the initial solutions
+! are solved by 2nd order RK method with the half time step size
+!
+! Weijia Kuang: 10/2002
+!
+ use mod_dimparam
+ use mod_sysparam
+ use mod_numparam
+ use mod_optparam
+
+ use mod_radgeom
+ use mod_artdis
+
+ use mod_rotation
+
+ use mod_vmatrix
+ use mod_bmatrix
+ use mod_tmatrix
+
+ use mod_cmbheat
+
+ use mod_dataio
+
+ implicit none
+
+ integer k,nd
+ integer i,j,nt1,nabam,nrunger,nrk2
+ integer unit_diag1,unit_diag2,unit_rec,unit_time
+ integer ndimg1,ndimg2,ndimg3,ndimg4
+ real (kind=8) dtmin,dtmax,tt,ttf,ttd,deltt1
+
+ real (kind=8) gzi,gzim1,gzim2,gzm,gzmm1,gzmm2
+
+ complex (kind=8) ghi,ghim1,ghim2,ghm,ghmm1,ghmm2
+
+ complex (kind=8), dimension(nmx2) :: fua,fuam1,fuam2,fub,
+ & fubm1,fubm2
+ complex (kind=8), dimension(nmx6,0:Lmax_m,0:mmax_m) :: fb,fbm1,
+ & fbm2,fj,fjm1,fjm2
+ complex (kind=8), dimension(nmx3,0:Lmax_t,0:mmax_t) :: ft,ftm1,
+ & ftm2
+
+ real (kind=8), allocatable :: delt_g(:,:,:,:), drhomm(:,:,:)
+
+C
+C SUBROUTINE STARTS HERE
+C
+
+ tt = tt0
+ ttf = 0.0
+ ttd = 0.0
+ j = 0
+ nd = 0
+
+C
+C ESTABLISHING OUTPUT CHANNELS FOR DIAGNOSTICS AND RECORDS
+C
+
+ call output_files(unit_diag1,unit_diag2,unit_rec,unit_time)
+
+C
+C Modeling parameters output
+C
+
+ call diagout(unit_diag1,unit_diag2,tt,nd,0)
+ call recout(unit_rec,0)
+
+C
+C INITIALIZING THE FORCING
+C
+
+ gzi = 0.0
+ gzim1 = 0.0
+ gzim2 = 0.0
+ gzm = 0.0
+ gzmm1 = 0.0
+ gzmm2 = 0.0
+
+ ghi = 0.0
+ ghim1 = 0.0
+ ghim2 = 0.0
+ ghm = 0.0
+ ghmm1 = 0.0
+ ghmm2 = 0.0
+
+ fua = 0.0
+ fuam1 = 0.0
+ fuam2 = 0.0
+ fub = 0.0
+ fubm1 = 0.0
+ fubm2 = 0.0
+ fb = 0.0
+ fbm1 = 0.0
+ fbm2 = 0.0
+ fj = 0.0
+ fjm1 = 0.0
+ fjm2 = 0.0
+ ft = 0.0
+ ftm1 = 0.0
+ ftm2 = 0.0
+
+!
+! Options of including mantle density anomaly effect
+!
+
+C
+C OBTAINING ASYMMETRIC VELOCITY (COVA,COVB) AT T = T_0 AND THE
+C FORCE (GZI,GZM,GHI,GHM,FUA,FUB,FB,FJ,FT) AT T_0
+C
+
+ call nonlinear(ndimg1,ndimg2,ndimg3,ndimg4,delt_g,drhomm,
+ & gzi,gzm,ghi,ghm,fua,fub,fb,fj,ft)
+
+ nt1 = 1
+
+C
+C UPDATING THE STATE VIA 2ND ORDER Runger-Kutter METHOD
+C
+
+ 10 continue
+
+ nabam = 0
+ nrk2 = 0
+ deltt1 = deltt
+ deltt = 0.5*deltt
+
+c Updating the matrices with the new time step
+
+ itrung = 2
+ call vmatrixu
+ call bmatrix
+ call tmatrix
+
+ do i = nt1,ntt
+
+c----------Updating (OMGI,OMGM,COUA,COUB,COB,COJ,COT)
+
+ call rungkt2(gzi,gzm,ghi,ghm,fua,fub,fb,fj,ft,
+ & delt_g,drhomm,ndimg1,ndimg2,ndimg3,
+ & ndimg4)
+ nrk2 = nrk2+1
+
+c----------Updating the nonlinear forcing at t_[k-1], t_[k-2]
+
+ if (nrk2 .gt. 1.5) then
+ gzim2 = gzim1
+ gzmm2 = gzmm1
+ ghim2 = ghim1
+ ghmm2 = ghmm1
+ fuam2 = fuam1
+ fubm2 = fubm1
+ fbm2 = fbm1
+ fjm2 = fjm1
+ ftm2 = ftm1
+ gzim1 = gzi
+ gzmm1 = gzm
+ ghim1 = ghi
+ ghmm1 = ghm
+ fuam1 = fua
+ fubm1 = fub
+ fbm1 = fb
+ fjm1 = fj
+ ftm1 = ft
+ nabam = nabam+1
+ nt1 = nt1+1
+ endif
+
+c----------Updating (COVA,COVB) and the nonlinear forcing at t_[k]
+
+ call nonlinear(ndimg1,ndimg2,ndimg3,ndimg4,delt_g,
+ & drhomm,gzi,gzm,ghi,ghm,fua,fub,fb,fj,ft)
+
+c----------Updating the time
+
+ tt = tt+deltt
+ ttf = ttf+deltt
+ ttd = ttd+deltt
+
+c----------data output
+
+ if (ttd.ge.toutd-1.e-9 .and. ttf.lt.toutf-1.e-9) then
+ call diagout(unit_diag1,unit_diag2,tt,nd,1)
+ ttd = 0.0
+ nd = nd+1
+ endif
+
+ if (ttf.ge.toutf-1.e-9 .or. i.gt.ntt-1) then
+ call diagout(unit_diag1,unit_diag2,tt,nd,2)
+ call recout(unit_rec,1)
+ call data_out1
+ ttf = 0.0
+ ttd = 0.0
+ nd = 0
+ fileno_out= fileno_out+1
+ endif
+
+c----------Testing the condition for AB-AM method
+
+ if (nabam .gt. 1.5) go to 11
+
+ enddo
+
+C
+C UPDATING THE STATE VIA 3RD ORDER AB-AM METHOD
+C
+
+ 11 continue
+
+ nrunger = 0
+ deltt = deltt1
+
+c Updating the matrices with the new time step
+
+ itrung = 2
+ call vmatrixu
+ call bmatrix
+ call tmatrix
+
+ do i = nt1,ntt
+
+c----------Updating (OMGI,OMGM,COUA,COUB,COB,COJ,COT)
+
+ call abam3(gzi,gzim1,gzim2,gzm,gzmm1,gzmm2,ghi,ghim1,
+ & ghim2,ghm,ghmm1,ghmm2,fua,fuam1,fuam2,fub,
+ & fubm1,fubm2,fb,fbm1,fbm2,fj,fjm1,fjm2,ft,
+ & ftm1,ftm2,delt_g,drhomm,ndimg1,ndimg2,
+ & ndimg3,ndimg4)
+
+c----------Updating the nonlinear forcing at t_[k-1], t_[k-2]
+
+ gzim2 = gzim1
+ gzmm2 = gzmm1
+ ghim2 = ghim1
+ ghmm2 = ghmm1
+ fuam2 = fuam1
+ fubm2 = fubm1
+ fbm2 = fbm1
+ fjm2 = fjm1
+ ftm2 = ftm1
+
+ gzim1 = gzi
+ gzmm1 = gzm
+ ghim1 = ghi
+ ghmm1 = ghm
+ fuam1 = fua
+ fubm1 = fub
+ fbm1 = fb
+ fjm1 = fj
+ ftm1 = ft
+
+c----------Updating (COVA,COVB) and the nonlinear forcing at t_[k]
+
+ call nonlinear(ndimg1,ndimg2,ndimg3,ndimg4,delt_g,
+ & drhomm,gzi,gzm,ghi,ghm,fua,fub,fb,fj,ft)
+
+c----------Updating the time
+
+ tt = tt+deltt
+ ttf = ttf+deltt
+ ttd = ttd+deltt
+
+ nt1 = i+1
+
+c----------Updating CFL condition
+
+ j = j+1
+ if (j.ge.ncfl .or. i.gt.ntt-1) then
+ dtmin = cflmin*cflno
+ dtmax = cflmax*cflno
+ if (deltt.lt.dtmin .or. deltt.gt.dtmax) then
+cts1 deltt = 0.5*(dtmin+dtmax)
+cts2 deltt = 0.25*(dtmin+dtmax)+0.5*deltt
+ nrunger= 1
+ call timeout(unit_time,tt)
+ endif
+ j = 0
+ if (deltt .lt. 1.e-15) then
+ call diagout(unit_diag1,unit_diag2,tt,nd,2)
+ call recout(unit_rec,1)
+ call data_out1
+ stop
+ endif
+ endif
+
+c----------Data output
+
+ if (ttd.ge.toutd-1.e-9 .and. ttf.lt.toutf-1.e-9) then
+ call diagout(unit_diag1,unit_diag2,tt,nd,1)
+ ttd = 0.0
+ nd = nd+1
+ endif
+
+
+ if (ttf.ge.toutf-1.e-9 .or. i.gt.ntt-1) then
+ call diagout(unit_diag1,unit_diag2,tt,nd,2)
+ call recout(unit_rec,1)
+ call data_out1
+ ttf = 0.0
+ ttd = 0.0
+ nd = 0
+ fileno_out= fileno_out+1
+ endif
+
+c----------Testing the condition for Runger-Kutter method
+
+ if (nrunger .gt. 0) go to 10
+
+ enddo
+
+ return
+ end
+
Property changes on: geodyn/3D/MoSST/trunk/evolutions.f
___________________________________________________________________
Name: svn:executable
+
Added: geodyn/3D/MoSST/trunk/forces.f
===================================================================
--- geodyn/3D/MoSST/trunk/forces.f 2006-10-23 16:55:10 UTC (rev 5079)
+++ geodyn/3D/MoSST/trunk/forces.f 2006-10-23 20:50:23 UTC (rev 5080)
@@ -0,0 +1,1769 @@
+c
+c This group of subroutines provide nonlinear force terms
+c for the geodynamo simulation. This version is for Sun
+c workstations with Sun Performance Library.
+c W.Kuang, 08/99
+c
+
+*************************************************************************
+*************************************************************************
+
+ subroutine nonlinear(ndimg1,ndimg2,ndimg3,ndimg4,delt_g,
+ & drhomm,gzi,gzm,ghi,ghm,fua,fub,fb,fj,ft)
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+c This subroutine has two purposes:
+c
+c for given field (OMGI,OMGM,COUA,COUB,COB,COJ,COT,COC)
+c at t_[k]:
+c
+c (1) Calculating (COVA,COVB) and hence (VLM,WLM) at t_[k];
+c (2) Calculating the nonlinear force (GZI,GZM,GHI,GHM,FUA,
+c FUB,FB,FJ,FT,FC) necessary to update (OMGI,
+c OMGM,COUA,COUB,COB,COJ,COT,COC) at t_[k+1];
+c
+c-----------------------------------------------------------------------
+c
+c Notation explanation:
+c
+c (sb,dsb,d2sb,sj,dsj): the spectral coefficients at radial
+c collocation points r_i;
+c (vr,vth,vph): the velocity components in physical space;
+c (wr,wth,wph): the vorticity components in physical space;
+c (br,bth,bph): the magnetic field in physical space;
+c (jr,jth,jph): the current density in physical space;
+c
+c (gzi,gzm,ghi,ghm,fua,fub,fb,fj,ft): the output
+c nonlinear forcing;
+c
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ use mod_dimparam
+ use mod_sysparam
+ use mod_numparam
+ use mod_optparam
+
+ use mod_parity
+ use mod_radgeom
+ use mod_sphgeom
+
+ use mod_vfield
+ use mod_bfield
+ use mod_tfield
+ use mod_rotation
+
+ use mod_cmbheat
+
+ implicit none
+
+c integer Lmax2
+c parameter (Lmax2=Lmax+2)
+
+ integer ndimg1,ndimg2,ndimg3,ndimg4
+ real (kind=8) gzi,gzm,torq_gz
+ complex (kind=8) ghi,ghm,torq_gh
+
+ real (kind=8) delt_g(ndimg1,ndimg2,0:ndimg3,3)
+ real (kind=8) drhomm(ndimg1,ndimg2,0:ndimg4)
+
+ complex (kind=8), dimension(nmx2) :: fua,fub
+ complex (kind=8), dimension(nmx6,0:Lmax_m,0:mmax_m) :: fb,fj
+ complex (kind=8) ft(nmx3,0:Lmax_t,0:mmax_t)
+
+ complex (kind=8), allocatable :: fga1(:,:,:), fga2(:,:,:)
+
+ integer i,j,k,k1,k2,L,L1,L2,Lcc1,Lcc2,m,n,nd_tp,n_st
+ integer idamax
+ real (kind=8) aj,c1,c2,c3,rr2i,rinv,dhp,hn1,hni1,hnm1,
+ & cfli,cflm
+ complex (kind=8) uim,ui,zeros,z1,z2
+
+ real (kind=8), dimension(npmax,ntmax,0:nmaxo) :: br,bth,
+ & bph,dj
+ real (kind=8), dimension(npmax,ntmax) :: vr,vth,vph,wr,
+ & wth,wph,jr,jth,jph,dtr,dtt,dtp,tmpr1,tmpr2,tmpr3
+
+ real (kind=8) cfll(nmxo1),tmpr4(ntmax)
+
+ complex (kind=8), dimension(nmx1) :: cova1,covb1
+ complex (kind=8), dimension(0:Lmax1,0:mmax,0:nmaxo) :: sv,
+ & dsv,d2sv,sw,dsw,sb,dsb,d2sb,sj,dsj,st,dst
+ complex (kind=8), dimension(0:Lmaxa,0:mmaxa) :: sbr,svr,
+ & tmpc1,tmpc2,tmpc3,tmpc4
+
+ complex (kind=8), dimension(0:Lmax,0:mmax,0:nmaxo) :: fb1,
+ & fb2a,fb2b,dfb2b
+ complex (kind=8), dimension(0:Lmax,0:mmax,0:nmaxi) :: fbi1,
+ & fbi2a,fbi2b
+ complex (kind=8), dimension(0:Lmax,0:mmax,0:nmaxm) :: fbm1,
+ & fbm2a,fbm2b
+
+ complex (kind=8), dimension(0:Lmax,miner+1,0:nmaxo) :: fv1,fv2a,
+ & fv2b,dfv2b
+ complex (kind=8), dimension(0:nmaxo,0:Lmax,0:mmax) :: qj,ft1
+
+ complex (kind=8), dimension(nmx1) :: fva,fvb
+ complex (kind=8) rot_m(6),torqb(6),torqv(6)
+
+
+C
+C SUBROUTINE STARTS HERE
+C
+
+ aj = cm*alphj/(rm*rath)
+ dhp = 2.0*pi/npmax
+ hn1 = -nmaxo/pi
+ hni1 = 1.0*nmaxi
+ hnm1 = 1.0*nmaxm
+ zeros = cmplx(0.0,0.0)
+ ui = cmplx(0.0,1.0)
+
+!
+! Initialization
+!
+
+ cfll = 0.0
+
+ gzi = 0.0
+ gzm = 0.0
+ ghi = 0.0
+ ghm = 0.0
+
+ fua = 0.0
+ fub = 0.0
+ fb = 0.0
+ fj = 0.0
+ ft = 0.0
+ qj = 0.0
+ ft1 = 0.0
+ fva = 0.0
+ fvb = 0.0
+ torqb = 0.0
+ torqv = 0.0
+
+C
+C PART I: UPDATING (COVA,COVB) FOR GIVEN (COB,COJ,COT,COC)
+C CALCULATING AXIAL TORQUE (GZI,GZM,GHI,GHM)
+C
+
+ br = 0.0
+ bth = 0.0
+ bph = 0.0
+ dj = 0.0
+
+ fb1 = 0.0
+ fb2a = 0.0
+ fb2b = 0.0
+ dfb2b = 0.0
+
+c
+c-------[1.1] OBTAINING {[1,d/dr,d^2/dr^2] b^[Lm], [1,d/dr] J^[Lm],
+c------- (1, d/dr) T^[Lm] } AT THE COLLOCATION POINT {r_i}
+c
+
+ do i = 0,nmaxo
+
+ sb(:,:,i) = 0.0
+ dsb(:,:,i) = 0.0
+ sj(:,:,i) = 0.0
+ dsj(:,:,i) = 0.0
+ st(:,:,i) = 0.0
+ dst(:,:,i) = 0.0
+
+ j = 2*i+1
+ k = 2*i+2
+ k1 = nmbic+j
+ k2 = nmbic+k
+ do m = 0,mmax_t
+ do L = m,Lmax_t
+ st(L,m,i) = cot(j,L,m)
+ dst(L,m,i) = cot(k,L,m)
+ enddo
+ enddo
+ do L = 1,Lmax_m
+ sb(L,0,i) = cob(k1,L,0)
+ dsb(L,0,i) = cob(k2,L,0)
+ sj(L,0,i) = coj(k1,L,0)
+ dsj(L,0,i) = coj(k2,L,0)
+ enddo
+ do m = 1,mmax_m
+ do L = m,Lmax_m
+ sb(L,m,i) = cob(k1,L,m)
+ dsb(L,m,i) = cob(k2,L,m)
+ sj(L,m,i) = coj(k1,L,m)
+ dsj(L,m,i) = coj(k2,L,m)
+ enddo
+ enddo
+ enddo
+
+ if (kicbb .eq. 2) then
+
+ k1 = nmbic-1
+ k2 = nmbic
+
+ do L = 1,Lmax_m
+ sb(L,0,0) = 0.5*(sb(L,0,0)+cob(k1,L,0))
+ dsb(L,0,0) = 0.5*(dsb(L,0,0)+cob(k2,L,0))
+ sj(L,0,0) = 0.5*(sj(L,0,0)+coj(k1,L,0))
+ enddo
+
+ do m = 1,mmax_m
+ do L = m,Lmax_m
+ sb(L,m,0) = 0.5*(sb(L,m,0)+cob(k1,L,m))
+ dsb(L,m,0) = 0.5*(dsb(L,m,0)+cob(k2,L,m))
+ sj(L,m,0) = 0.5*(sj(L,m,0)+coj(k1,L,m))
+ enddo
+ enddo
+
+ endif
+
+ if (kcmbb .eq. 2) then
+
+ k1 = nmx3+nmbic+1
+ k2 = nmx3+nmbic+2
+
+ do L = 1,Lmax_m
+ sb(L,0,nmaxo) = 0.5*(sb(L,0,nmaxo)+cob(k1,L,0))
+ dsb(L,0,nmaxo) = 0.5*(dsb(L,0,nmaxo)+cob(k2,L,0))
+ sj(L,0,nmaxo) = 0.5*(sj(L,0,nmaxo)+coj(k1,L,0))
+ enddo
+
+ do m = 1,mmax_m
+ do L = m,Lmax_m
+ sb(L,m,nmaxo) = 0.5*(sb(L,m,nmaxo)+cob(k1,L,m))
+ dsb(L,m,nmaxo) = 0.5*(dsb(L,m,nmaxo)+cob(k2,L,m))
+ sj(L,m,nmaxo) = 0.5*(sj(L,m,nmaxo)+coj(k1,L,m))
+ enddo
+ enddo
+
+ endif
+
+ d2sb = 0.0
+
+ do m = 0,mmax_m
+ do L = m,Lmax_m
+ d2sb(L,m,0) = dsb(L,m,0)*dr1(0,1)+dsb(L,m,1)*
+ & dr1(0,2)+dsb(L,m,2)*dr1(0,3)+
+ & dsb(L,m,3)*dr1(0,4)+dsb(L,m,4)*
+ & dr1(0,5)
+ d2sb(L,m,1) = dsb(L,m,0)*dr1(1,1)+dsb(L,m,1)*
+ & dr1(1,2)+dsb(L,m,2)*dr1(1,3)+
+ & dsb(L,m,3)*dr1(1,4)+dsb(L,m,4)*
+ & dr1(1,5)
+ d2sb(L,m,nmaxo-1)= dsb(L,m,nmaxo-4)*dr1(nmaxo-1,1)
+ & +dsb(L,m,nmaxo-3)*dr1(nmaxo-1,2)+
+ & dsb(L,m,nmaxo-2)*dr1(nmaxo-1,3)+
+ & dsb(L,m,nmaxo-1)*dr1(nmaxo-1,4)+
+ & dsb(L,m,nmaxo)*dr1(nmaxo-1,5)
+ d2sb(L,m,nmaxo) = dsb(L,m,nmaxo-4)*dr1(nmaxo,1)+
+ & dsb(L,m,nmaxo-3)*dr1(nmaxo,2)+
+ & dsb(L,m,nmaxo-2)*dr1(nmaxo,3)+
+ & dsb(L,m,nmaxo-1)*dr1(nmaxo,4)+
+ & dsb(L,m,nmaxo)*dr1(nmaxo,5)
+ enddo
+ enddo
+
+ do i = 2,nmaxo-2
+ do m = 0,mmax_m
+ do L = m,Lmax_m
+ d2sb(L,m,i) = dsb(L,m,i-2)*dr1(i,1)+dsb(L,m,i-1)
+ & *dr1(i,2)+dsb(L,m,i+1)*dr1(i,4)+
+ & dsb(L,m,i+2)*dr1(i,5)
+ enddo
+ enddo
+ enddo
+
+c
+c
+c-------[1.2] OBTAINING THE FORCE (COVA,COVB) at {r_i}
+c------- BY MEANS OF SPHERICAL TRANSFORM
+c
+
+ do i = 0,nmaxo
+
+ rr2i = rr(i)*rr(i)
+ rinv = 1.0/rr2i
+
+c
+c----------[1.2.1] Inverse Transform of [J X B] From Spectral Space to
+c Physical Space
+c
+
+c----------the values of {r^2 (br,jr)} at {r_i}
+
+ sbr = 0.0
+ tmpc1 = 0.0
+ do m = 0,mmax
+ sbr(m:Lmax,m) = LL(m:Lmax)*sb(m:Lmax,m,i)
+ tmpc1(m:Lmax,m)= LL(m:Lmax)*sj(m:Lmax,m,i)
+ enddo
+
+ call izfspht(sbr,aslg,table,Lmaxa,mmaxa,ntmax,npmax,
+ & br(1,1,i))
+ call izfspht(tmpc1,aslg,table,Lmaxa,mmaxa,ntmax,
+ & npmax,jr)
+
+c----------the values of { r sin(th) [b_th, b_ph, j_th, j_ph] } at {r_i}
+
+ tmpc1 = 0.0
+ tmpc2 = 0.0
+ tmpc3 = 0.0
+ tmpc4 = 0.0
+ do m = 0,mmax
+ uim = cmplx(0.0,1.0*m)
+ do L = m+1,Lmax
+ tmpc1(L,m) = uim*sj(L,m,i)+clm(L,m,1)*dsb(L-1,m,i)
+ & -clm(L,m,2)*dsb(L+1,m,i)
+ tmpc2(L,m) = uim*dsb(L,m,i)-clm(L,m,1)*sj(L-1,m,i)
+ & +clm(L,m,2)*sj(L+1,m,i)
+ tmpc3(L,m) = uim*(rinv*sbr(L,m)-d2sb(L,m,i))+
+ & clm(L,m,1)*dsj(L-1,m,i)-clm(L,m,2)*
+ & dsj(L+1,m,i)
+ tmpc4(L,m) = uim*dsj(L,m,i)+clm(L,m,1)*
+ & (d2sb(L-1,m,i)-rinv*sbr(L-1,m))-
+ & clm(L,m,2)*(d2sb(L+1,m,i)-rinv*
+ & sbr(L+1,m))
+ enddo
+ tmpc1(m,m) = uim*sj(m,m,i)-clm(m,m,2)*dsb(m+1,m,i)
+ tmpc2(m,m) = uim*dsb(m,m,i)+clm(m,m,2)*sj(m+1,m,i)
+ tmpc3(m,m) = uim*(rinv*sbr(m,m)-d2sb(m,m,i))-
+ & clm(m,m,2)*dsj(m+1,m,i)
+ tmpc4(m,m) = uim*dsj(m,m,i)-clm(m,m,2)*(d2sb(m+1,m,i)
+ & -rinv*sbr(m+1,m))
+ enddo
+
+ call izfspht(tmpc1,aslg,table,Lmaxa,mmaxa,ntmax,
+ & npmax,bth(1,1,i))
+ call izfspht(tmpc2,aslg,table,Lmaxa,mmaxa,ntmax,
+ & npmax,bph(1,1,i))
+ call izfspht(tmpc3,aslg,table,Lmaxa,mmaxa,ntmax,
+ & npmax,jth)
+ call izfspht(tmpc4,aslg,table,Lmaxa,mmaxa,ntmax,
+ & npmax,jph)
+
+c
+c----------[1.2.2] Transform of [ M (J X B) ] From Physical Space to
+c Spectral Space to Obtain The Force (COVA,COVB)
+c
+
+c----------the terms
+c----------A_1r = {[r sin(th) J_th] [r sin(th) B_ph] -
+c---------- [r sin(th) J_ph] [r sin(th) B_th]}/[r sin(th)]**2 (tmpc1)
+c----------A_1t = {[r sin(th) J_ph] [r^2 B_r] - [r^2 J_r]
+c---------- [r sin(th) B_ph]}/[r sin(th)]**2 (tmpc2)
+c----------A_1p = {[r^2 J_r] [r sin(th) B_th] - [r sin(th) J_th]
+c---------- [r^2 B_r]}/[r sin(th)]**2 (tmpc3)
+c----------at {r_i}
+
+
+ do k = 1,ntmax
+ c1= rinv/sins(k)**2
+ tmpr1(:,k) = c1*(jth(:,k)*bph(:,k,i)-jph(:,k)*
+ & bth(:,k,i))
+ tmpr2(:,k) = c1*(jph(:,k)*br(:,k,i)-jr(:,k)*
+ & bph(:,k,i))
+ tmpr3(:,k) = c1*(jr(:,k)*bth(:,k,i)-jth(:,k)*
+ & br(:,k,i))
+ enddo
+
+ call zfspht(tmpr1,aslg,gauwt,table,Lmaxa,mmaxa,ntmax,
+ & npmax,tmpc1)
+ call zfspht(tmpr2,aslg,gauwt,table,Lmaxa,mmaxa,ntmax,
+ & npmax,tmpc2)
+ call zfspht(tmpr3,aslg,gauwt,table,Lmaxa,mmaxa,ntmax,
+ & npmax,tmpc3)
+
+c----------the term
+c----------J^2 = {J_r^2 + J_th^2 + J_ph^2} (tmpc4)
+c----------at {r_i}
+
+ c1 = rinv**2
+ do k = 1,ntmax
+ c2= rinv/sins(k)**2
+ tmpr1(:,k) = c1*jr(:,k)*jr(:,k)+c2*(jth(:,k)*jth(:,k)
+ & +jph(:,k)*jph(:,k))
+ enddo
+
+ call zfspht(tmpr1,aslg,gauwt,table,Lmaxa,mmaxa,ntmax,
+ & npmax,tmpc4)
+
+c----------the forces:
+c----------fb1 = [sin(th) d/dth + 2 cos(th)] A_1p - d/dph A_1t;
+c----------fb2b = [sin(th) d/dth + 2 cos(th)] A_1t + d/dph A_1p;
+c----------fb2a = M A_1r + (R_th T + R_co C);
+
+ do m = 0,mmax
+ uim = cmplx(0.0,1.0*m)
+ do L = m+1,Lmax
+ fb1(L,m,i) = -uim*tmpc2(L,m)+clm(L,m,3)*
+ & tmpc3(L-1,m)-clm(L,m,4)*tmpc3(L+1,m)
+ fb2b(L,m,i)= uim*tmpc3(L,m)+clm(L,m,3)*
+ & tmpc2(L-1,m)-clm(L,m,4)*tmpc2(L+1,m)
+ enddo
+ fb1(m,m,i) = -uim*tmpc2(m,m)-clm(m,m,4)*tmpc3(m+1,m)
+ fb2b(m,m,i)= uim*tmpc3(m,m)-clm(m,m,4)*tmpc2(m+1,m)
+ enddo
+
+ do m = 0,mmax
+ fb2a(m:Lmax,m,i) = cm*tmpc1(m:Lmax,m)+rath*
+ & st(m:Lmax,m,i)
+ enddo
+
+c----------the Joul heating qj = r J^2
+
+ do m = 0,mmax
+ do L = m,Lmax
+ qj(i,L,m) = rr(i)*tmpc4(L,m)
+ enddo
+ enddo
+
+c----------the (J x Delta)_r term
+
+ do k = 1,ntmax
+ c1= 1.0/(rr(i)*sins(k))
+ c2= rr(i)*c1*c1/dhp
+ dj(:,k,i) = abs(c2*jth(:,k))+abs(jph(:,k)*c1/dht(k))
+ enddo
+
+ enddo
+
+c
+c-------[1.3] Calculating [d/dr fb2b] at {r_i | i = 1,...,n-1} with
+c------- finite difference approximation
+c
+
+ do i = 2,nmaxo-2
+ dfb2b(:,:,i) = dr1(i,1)*fb2b(:,:,i-2)+dr1(i,2)*
+ & fb2b(:,:,i-1)+dr1(i,4)*fb2b(:,:,i+1)
+ & +dr1(i,5)*fb2b(:,:,i+2)
+ enddo
+
+c
+c-------[1.4] Obtain (FVA,FVB) and part of (FUA,FUB) from the
+c------- Lorentz force and the buoyancy force
+c
+
+ do i = 1,nmaxo-1
+
+c The force (FVA,FVB)
+
+ do m = miner+1,mmax_v
+ do k = 0,lsym_v(m)
+
+c----------------Group I: L = m+2*k,
+c----------------COVA = M fb1/[L(L+1)]; COVB = M dfb2b/[L(L+1)] + fb2a
+c----------------Group II: L = m+2*L1+1,
+c----------------COVA = M dfb2b/[L(L+1)] + fb2a; COVB = M fb1/[L(L+1)]
+
+ L1 = m+2*k
+ L2 = m+2*k+1
+ Lcc1= kdm(m-1)-kdm(miner)+2*k*nmxo1+i+1
+ Lcc2= kdm(m-1)-kdm(miner)+(2*k+1)*nmxo1+i+1
+ c1 = cm/LL(L1)
+ c2 = cm/LL(L2)
+ fva(Lcc1)= c1*fb1(L1,m,i)
+ fva(Lcc2)= c2*dfb2b(L2,m,i)+fb2a(L2,m,i)
+ fvb(Lcc1)= c1*dfb2b(L1,m,i)+fb2a(L1,m,i)
+ fvb(Lcc2)= c2*fb1(L2,m,i)
+
+ enddo
+ enddo
+
+c The force (FUA,FUB)
+
+ do k = 1,lsym_v(0)
+
+c-------------Group I: L = 2*k-1
+c-------------FUA = M dfb2b/[L(L+1)] + fb2a; FUB = M fb1/[L(L+1)]
+c-------------Group II: L = 2*k
+c-------------FUA = M fb1/[L(L+1)]; FUB = M dfb2b/[L(L+1)] + fb2a
+
+ L1 = 2*k-1
+ L2 = 2*k
+ Lcc1= 2*(k-1)*nmxo1+i+1
+ Lcc2= (2*k-1)*nmxo1+i+1
+ c1 = cm/LL(L1)
+ c2 = cm/LL(L2)
+ fua(Lcc1)= c1*dfb2b(L1,0,i)+fb2a(L1,0,i)
+ fua(Lcc2)= c2*fb1(L2,0,i)
+ fub(Lcc1)= c1*fb1(L1,0,i)
+ fub(Lcc2)= c2*dfb2b(L2,0,i)+fb2a(L2,0,i)
+
+ enddo
+
+ do m = 1,miner
+ do k = 0,lsym_v(m)
+
+c-------------Group III: L = m+2*k,
+c-------------FUB = M fb1/[L(L+1)]; FUA = M dfb2b/[L(L+1)] + fb2a
+c-------------Group IV: L = m+2*L1+1,
+c-------------FUB = M dfb2b/[L(L+1)] + fb2a; FUA = M fb1/[L(L+1)]
+
+ L1 = m+2*k
+ L2 = m+2*k+1
+ Lcc1= kdm(m-1)+2*k*nmxo1+i+1
+ Lcc2= kdm(m-1)+(2*k+1)*nmxo1+i+1
+ c1 = cm/LL(L1)
+ c2 = cm/LL(L2)
+ fua(Lcc1)= c1*dfb2b(L1,m,i)+fb2a(L1,m,i)
+ fua(Lcc2)= c2*fb1(L2,m,i)
+ fub(Lcc1)= c1*fb1(L1,m,i)
+ fub(Lcc2)= c2*dfb2b(L2,m,i)+fb2a(L2,m,i)
+
+ enddo
+ enddo
+
+ enddo
+
+!
+!-------[1.5] Determine if buoyancy anomaly force arising from mantle
+! density anomaly needs to be included
+!
+
+c
+c-------[1.6] Evaluating (COVA,COVB)
+c
+
+ cova1 = fva
+ covb1 = fvb
+
+c-------Boundary conditions for (COVA,COVB)
+
+ do m = miner+1,mmax_v
+ do L1= 0,lsym_v(m)
+ k1= kdm(m-1)-kdm(miner)+2*L1*nmxo1
+ k2= kdm(m-1)-kdm(miner)+(2*L1+1)*nmxo1
+ cova1(k1+1) = 0.0
+ cova1(k1+nmxo1)= 0.0
+ covb1(k1+1) = 0.0
+ covb1(k1+2) = 0.0
+ covb1(k1+nmaxo)= 0.0
+ covb1(k1+nmxo1)= 0.0
+ cova1(k2+1) = 0.0
+ cova1(k2+2) = 0.0
+ cova1(k2+nmaxo)= 0.0
+ cova1(k2+nmxo1)= 0.0
+ covb1(k2+1) = 0.0
+ covb1(k2+nmxo1)= 0.0
+ enddo
+ enddo
+
+ call solverv(cova1,covb1)
+
+C
+C PART II: OBTAINING THE FORCE (FUA,FUB) FOR
+C (COUA,COUB) AND (FB,FJ,FT,FC)
+C FOR (COB,COJ,COT,COC)
+C
+
+ fv1 = 0.0
+ fv2a = 0.0
+ fv2b = 0.0
+ dfv2b = 0.0
+ fb1 = 0.0
+ fb2a = 0.0
+ fb2b = 0.0
+ dfb2b = 0.0
+
+c
+c-------[2.1] OBTAINING {[1, d/dr, d^2/dr^2] v^[Lm], [1, d/dr] w^[Lm]}
+c------- AT THE COLLOCATION POINT {r_i}
+c
+
+ do i = 0,nmaxo
+
+ sv(:,:,i) = 0.0
+ dsv(:,:,i) = 0.0
+ d2sv(:,:,i) = 0.0
+ sw(:,:,i) = 0.0
+ dsw(:,:,i) = 0.0
+
+ do n = 0,nmax_v
+ do L = 1,Lmax_v
+ sv(L,0,i) = sv(L,0,i)+cheb(n,i)*vlm(n,L,0)
+ dsv(L,0,i) = dsv(L,0,i)+dch1(n,i)*vlm(n,L,0)
+ d2sv(L,0,i)= d2sv(L,0,i)+dch2(n,i)*vlm(n,L,0)
+ sw(L,0,i) = sw(L,0,i)+cheb(n,i)*wlm(n,L,0)
+ dsw(L,0,i) = dsw(L,0,i)+dch1(n,i)*wlm(n,L,0)
+ enddo
+ do m = 1,mmax_v
+ do L = m,Lmax_v
+ sv(L,m,i) = sv(L,m,i)+cheb(n,i)*vlm(n,L,m)
+ dsv(L,m,i) = dsv(L,m,i)+dch1(n,i)*vlm(n,L,m)
+ d2sv(L,m,i)= d2sv(L,m,i)+dch2(n,i)*vlm(n,L,m)
+ sw(L,m,i) = sw(L,m,i)+cheb(n,i)*wlm(n,L,m)
+ dsw(L,m,i) = dsw(L,m,i)+dch1(n,i)*wlm(n,L,m)
+ enddo
+ enddo
+ enddo
+
+ enddo
+
+c
+c The rotations of the mantle
+c
+
+ rot_m = 0.0
+ rot_m(1)= 2.0*sqrt(pi/3.0)*omgmz
+ rot_m(2)= -sqrt(2.0*pi/3.0)*conjg(omgmh)
+ rot_m(3)= -4.0*sqrt(pi)*omgmz/3.0
+ rot_m(4)= 4.0*sqrt(pi/5.0)*omgmz/3.0
+ rot_m(5)= -sqrt(2.0*pi/15.0)*conjg(omgmh)
+ rot_m(6)= -ui*sqrt(2.0*pi/3.0)*conjg(omgmh)
+
+c
+c-------[2.2] OBTAINING THE FORCE (FUA,FUB,FB,FJ,FT,FC) ON THE
+c------- COLLOCATION POINTS {r_i} BY MEANS OF SPHERICAL
+c------- TRANSFORM
+c
+
+ do i = 0,nmaxo
+
+ rr2i = rr(i)*rr(i)
+ rinv = 1.0/rr2i
+
+c
+c----------[2.2.1] Inverse Transform of [W X V] From Spectral Space to
+c Physical Space
+c
+
+c----------the values of {r^2 (vr,wr), (r d/dr 1/r, d/dph) T} at {r_i}
+
+ svr = 0.0
+ tmpc1 = 0.0
+ tmpc2 = 0.0
+ tmpc3 = 0.0
+ c1 = 1.0/rr(i)
+ do m = 0,mmax
+ uim = cmplx(0.0,1.0*m)
+ svr(m:Lmax,m) = LL(m:Lmax)*sv(m:Lmax,m,i)
+ tmpc1(m:Lmax,m)= LL(m:Lmax)*sw(m:Lmax,m,i)
+ tmpc2(m:Lmax,m)= dst(m:Lmax,m,i)-c1*
+ & st(m:Lmax,m,i)
+ tmpc3(m:Lmax,m)= uim*st(m:Lmax,m,i)
+ enddo
+ tmpc1(1,0) = tmpc1(1,0)+rr2i*rot_m(1)
+ tmpc1(1,1) = tmpc1(1,1)+rr2i*rot_m(2)
+
+ call izfspht(svr,aslg,table,Lmaxa,mmaxa,ntmax,
+ & npmax,vr)
+ call izfspht(tmpc1,aslg,table,Lmaxa,mmaxa,ntmax,
+ & npmax,wr)
+ call izfspht(tmpc2,aslg,table,Lmaxa,mmaxa,ntmax,
+ & npmax,dtr)
+ call izfspht(tmpc3,aslg,table,Lmaxa,mmaxa,ntmax,
+ & npmax,dtp)
+
+c----------the values of {r sin(th) [v_th, v_ph, w_th, w_ph]} at {r_i}
+
+ tmpc1 = 0.0
+ tmpc2 = 0.0
+ tmpc3 = 0.0
+ tmpc4 = 0.0
+ do m = 0,mmax
+ uim = cmplx(0.0,1.0*m)
+ do L = m+1,Lmax
+ tmpc1(L,m) = uim*sw(L,m,i)+clm(L,m,1)*dsv(L-1,m,i)
+ & -clm(L,m,2)*dsv(L+1,m,i)
+ tmpc2(L,m) = uim*dsv(L,m,i)-clm(L,m,1)*sw(L-1,m,i)
+ & +clm(L,m,2)*sw(L+1,m,i)
+ tmpc3(L,m) = uim*(rinv*svr(L,m)-d2sv(L,m,i))+
+ & clm(L,m,1)*dsw(L-1,m,i)-clm(L,m,2)*
+ & dsw(L+1,m,i)
+ tmpc4(L,m) = uim*dsw(L,m,i)+clm(L,m,1)*
+ & (d2sv(L-1,m,i)-rinv*svr(L-1,m))-
+ & clm(L,m,2)*(d2sv(L+1,m,i)-rinv*
+ & svr(L+1,m))
+ enddo
+ tmpc1(m,m) = uim*sw(m,m,i)-clm(m,m,2)*dsv(m+1,m,i)
+ tmpc2(m,m) = uim*dsv(m,m,i)+clm(m,m,2)*sw(m+1,m,i)
+ tmpc3(m,m) = uim*(rinv*svr(m,m)-d2sv(m,m,i))-
+ & clm(m,m,2)*dsw(m+1,m,i)
+ tmpc4(m,m) = uim*dsw(m,m,i)-clm(m,m,2)*(d2sv(m+1,m,i)
+ & -rinv*svr(m+1,m))
+ enddo
+ tmpc3(0,0) = tmpc3(0,0)+rr(i)*rot_m(3)
+ tmpc3(2,0) = tmpc3(2,0)+rr(i)*rot_m(4)
+ tmpc3(2,1) = tmpc3(2,1)+rr(i)*rot_m(5)
+ tmpc4(1,1) = tmpc4(1,1)+rr(i)*rot_m(6)
+
+ call izfspht(tmpc1,aslg,table,Lmaxa,mmaxa,ntmax,
+ & npmax,vth)
+ call izfspht(tmpc2,aslg,table,Lmaxa,mmaxa,ntmax,
+ & npmax,vph)
+ call izfspht(tmpc3,aslg,table,Lmaxa,mmaxa,ntmax,
+ & npmax,wth)
+ call izfspht(tmpc4,aslg,table,Lmaxa,mmaxa,ntmax,
+ & npmax,wph)
+
+c----------the values of {sin(th) d/dth T} at {r_i}
+
+ tmpc1 = 0.0
+ do m = 0,mmax
+ do L = m+1,Lmax
+ tmpc1(L,m) = clm(L,m,1)*st(L-1,m,i)-clm(L,m,2)*
+ & st(L+1,m,i)
+ enddo
+ tmpc1(m,m) = -clm(m,m,2)*st(m+1,m,i)
+ enddo
+
+ call izfspht(tmpc1,aslg,table,Lmaxa,mmaxa,ntmax,
+ & npmax,dtt)
+
+c
+c----------[2.2.2] Transform of [W X V, CURL (V X B), (V.GRAD)T] From
+c Physical Space to Spectral Space to Obtain The
+c Forces (FUA, FUB, FB, FJ, FT, FC)
+c
+
+c----------the terms
+c----------A_2r = {[r sin(th) W_th] [r sin(th) V_ph] -
+c---------- [r sin(th) W_ph] [r sin(th) V_th]}/[r sin(th)]**2 (tmpc1)
+c----------A_2t = {[r sin(th) W_ph] [r^2 V_r] - [r^2 W_r]
+c---------- [r sin(th) V_ph]}/[r sin(th)]**2 (tmpc2)
+c----------A_2p = {[r^2 W_r] [r sin(th) V_th] - [r sin(th) W_th]
+c---------- [r^2 V_r]}/[r sin(th)]**2 (tmpc3)
+c----------at {r_i}
+
+ do k = 1,ntmax
+ c1= rinv/sins(k)**2
+ tmpr1(:,k) = c1*(wth(:,k)*vph(:,k)-wph(:,k)*
+ & vth(:,k))
+ tmpr2(:,k) = c1*(wph(:,k)*vr(:,k)-wr(:,k)*
+ & vph(:,k))
+ tmpr3(:,k) = c1*(wr(:,k)*vth(:,k)-wth(:,k)*
+ & vr(:,k))
+ enddo
+
+ call zfspht(tmpr1,aslg,gauwt,table,Lmaxa,mmaxa,ntmax,
+ & npmax,tmpc1)
+ call zfspht(tmpr2,aslg,gauwt,table,Lmaxa,mmaxa,ntmax,
+ & npmax,tmpc2)
+ call zfspht(tmpr3,aslg,gauwt,table,Lmaxa,mmaxa,ntmax,
+ & npmax,tmpc3)
+
+c----------the forces (for m<=miner only):
+c----------fv1 = [sin(th) d/dth + 2 cos(th)] A2p - d/dph A2t;
+c----------fv2b = [sin(th) d/dth + 2 cos(th)] A2t + d/dph A2p;
+c----------fv2a = R_o A2r;
+
+ do m = 0,miner
+ uim = cmplx(0.0,1.0*m)
+ do L = m+1,Lmax
+ fv1(L,m+1,i) = -uim*tmpc2(L,m)+clm(L,m,3)*
+ & tmpc3(L-1,m)-clm(L,m,4)*tmpc3(L+1,m)
+ fv2b(L,m+1,i)= uim*tmpc3(L,m)+clm(L,m,3)*
+ & tmpc2(L-1,m)-clm(L,m,4)*tmpc2(L+1,m)
+ enddo
+ fv1(m,m+1,i) = -uim*tmpc2(m,m)-clm(m,m,4)*tmpc3(m+1,m)
+ fv2b(m,m+1,i)= uim*tmpc3(m,m)-clm(m,m,4)*tmpc2(m+1,m)
+ enddo
+
+ do m = 0,miner
+ fv2a(m:Lmax,m+1,i) = ro*tmpc1(m:Lmax,m)
+ enddo
+
+c----------the terms
+c----------A_3r = {[r sin(th) v_th] [r sin(th) B_ph] -
+c---------- [r sin(th) v_ph] [r sin(th) B_th]}/[r sin(th)]^2 (tmpc1)
+c----------A_3t = {[r sin(th) v_ph] [r^2 B_r] - [r^2 v_r]
+c---------- [r sin(th) B_ph]}/[r sin(th)]^2 (tmpc2)
+c----------A_3p = {[r^2 v_r] [r sin(th) B_th] - [r sin(th) v_th]
+c---------- [r^2 B_r]}/[r sin(th)]^2 (tmpc3)
+c----------at {r_i}
+
+ do k = 1,ntmax
+ c1= rinv/sins(k)**2
+ tmpr1(:,k) = c1*(vth(:,k)*bph(:,k,i)-vph(:,k)*
+ & bth(:,k,i))
+ tmpr2(:,k) = c1*(vph(:,k)*br(:,k,i)-vr(:,k)*
+ & bph(:,k,i))
+ tmpr3(:,k) = c1*(vr(:,k)*bth(:,k,i)-vth(:,k)*
+ & br(:,k,i))
+ enddo
+
+ call zfspht(tmpr1,aslg,gauwt,table,Lmaxa,mmaxa,ntmax,
+ & npmax,tmpc1)
+ call zfspht(tmpr2,aslg,gauwt,table,Lmaxa,mmaxa,ntmax,
+ & npmax,tmpc2)
+ call zfspht(tmpr3,aslg,gauwt,table,Lmaxa,mmaxa,ntmax,
+ & npmax,tmpc3)
+
+c----------the forces:
+c----------fb1 = [sin(th) d/dth + 2 cos(th)] A_3p - d/dph A_3t;
+c----------fb2b = [sin(th) d/dth + 2 cos(th)] A_3t + d/dph A_3p;
+c----------fb2a = A_3r;
+
+ do m = 0,mmax
+ uim = cmplx(0.0,1.0*m)
+ do L = m+1,Lmax
+ fb1(L,m,i) = -uim*tmpc2(L,m)+clm(L,m,3)*
+ & tmpc3(L-1,m)-clm(L,m,4)*tmpc3(L+1,m)
+ fb2b(L,m,i)= uim*tmpc3(L,m)+clm(L,m,3)*
+ & tmpc2(L-1,m)-clm(L,m,4)*tmpc2(L+1,m)
+ enddo
+ fb1(m,m,i) = -uim*tmpc2(m,m)-clm(m,m,4)*tmpc3(m+1,m)
+ fb2b(m,m,i)= uim*tmpc3(m,m)-clm(m,m,4)*tmpc2(m+1,m)
+ enddo
+
+ do m = 0,mmax
+ fb2a(m:Lmax,m,i) = tmpc1(m:Lmax,m)
+ enddo
+
+c----------the term
+c----------A_4 = - r [vr (d/dr T_0) + (v.GRAD) T] (tmpc4)
+c----------at{r_i}
+
+ c2 = rr(i)*dt0r(i)
+ do k = 1,ntmax
+ c1= rinv/sins(k)**2
+ tmpr1(:,k) = -rinv*vr(:,k)*(dtr(:,k)-c2)-c1*
+ & (vth(:,k)*dtt(:,k)+vph(:,k)*dtp(:,k))
+ enddo
+
+ call zfspht(tmpr1,aslg,gauwt,table,Lmaxa,mmaxa,ntmax,
+ & npmax,tmpc4)
+
+c----------The force FT1 = A_4
+
+ do m = 0,mmax
+ do L = m,Lmax
+ ft1(i,L,m) = tmpc4(L,m)
+ enddo
+ enddo
+
+c
+c----------[2.2.3] The Local CFL Conditions
+c
+
+c----------The (B.Delta) and (V.Delta) terms
+
+ tmpr1= 0.0
+ tmpr2= 0.0
+ do k = 1,ntmax
+ c1= rinv/sins(k)
+ c2= rinv/(dhp*sins(k)**2)
+ tmpr1(:,k) = rinv*abs(vr(:,k)/dhr(i+1))+
+ & abs(c1*vth(:,k)/dht(k))+
+ & abs(c2*vph(:,k))
+ tmpr2(:,k) = rinv*abs(br(:,k,i)/dhr(i+1))+
+ & abs(c1*bth(:,k,i)/dht(k))+
+ & abs(c2*bph(:,k,i))
+ enddo
+
+c----------The local eigenvalues for CFL condition
+
+ tmpr3= 0.0
+
+ c1 = abs(aj*rr(i))
+ c2 = 1.0/sqrt(ro)
+ c3 = abs(rath*dt0r(i)*rr(i))
+
+ tmpr4= 0.0
+ tmpr3= tmpr1+c2*sqrt(tmpr2*tmpr2+c3)+c1*tmpr2
+ & *dj(:,:,i)/(tmpr2*tmpr2+c3)
+
+ do k = 1,ntmax
+ k1 = idamax(npmax,tmpr3(1,k),1)
+ tmpr4(k) = tmpr3(k1,k)
+ enddo
+
+ k1 = idamax(ntmax,tmpr4(1),1)
+ cfll(i+1) = tmpr4(k1)
+
+ enddo
+
+c
+c-------[2.3] EVALUATING CFL CONDITION NUMBER CFLNO
+c
+
+ k1 = idamax(nmxo1,cfll(1),1)
+
+ c1 = cfll(k1)
+
+ cflno = 1.0/c1
+
+ if (kicbv.ne.1 .and. kicbb.eq.2) then
+
+ do k = 1,ntmax
+ c1= abs(omgih)/sqrt(2.0)*(abs(th(k)/sins(k)*dhp)+
+ & abs(dht(k)))+abs(omgiz*dhp)
+ do j = 1,npmax
+ tmpr1(j,k) = c1+sqrt(c1*c1+4.0*cm/(rhoio*mti*ro)
+ & *br(j,k,0)**2)
+ enddo
+ enddo
+
+ do k = 1,ntmax
+ k1= idamax(npmax,tmpr1(1,k),1)
+ tmpr2(k,1)= tmpr1(k1,k)
+ enddo
+
+ k1 = idamax(ntmax,tmpr2(1,1),1)
+
+ c1 = tmpr2(k1,1)
+
+ if (c1 .gt. 0.0) then
+ c1 = 2.0/c1
+ if (c1 .lt. cflno) cflno = c1
+ endif
+
+ endif
+
+c
+c-------[2.4] CALCULATING [d/dr fv2b] AT {r_i | i = 1,...,n-1} WITH
+c------- FINITE DIFFERENCE APPROXIMATION
+c
+
+ do i = 2,nmaxo-2
+ dfv2b(:,:,i) = dr1(i,1)*fv2b(:,:,i-2)+dr1(i,2)*
+ & fv2b(:,:,i-1)+dr1(i,4)*fv2b(:,:,i+1)+
+ & dr1(i,5)*fv2b(:,:,i+2)
+ enddo
+
+
+c
+c-------[2.5] Evaluating (FUA,FUB) IN THE OUTER CORE
+c
+
+ do i = 1,nmaxo-1
+
+ do k = 1,lsym_v(0)
+
+c-------------Group I: L = 2*k-1
+c-------------FUA = FUA - (r_on dfv2b/[L(L+1)] + fv2a)
+c-------------FUB = FUB - r_on fv1/[L(L+1)]
+c-------------Group II: L = 2*k
+c-------------FUA = FUA - r_on fv1/[L(L+1)]
+c-------------FUB = FUB - (r_on dfv2b/[L(L+1)] + fv2a)
+
+ L1 = 2*k-1
+ L2 = 2*k
+ Lcc1= 2*(k-1)*nmxo1+i+1
+ Lcc2= (2*k-1)*nmxo1+i+1
+ c1 = ron/LL(L1)
+ c2 = ron/LL(L2)
+ fua(Lcc1)= fua(Lcc1)-c1*dfv2b(L1,1,i)-fv2a(L1,1,i)
+ fua(Lcc2)= fua(Lcc2)-c2*fv1(L2,1,i)
+ fub(Lcc1)= fub(Lcc1)-c1*fv1(L1,1,i)
+ fub(Lcc2)= fub(Lcc2)-c2*dfv2b(L2,1,i)-fv2a(L2,1,i)
+
+ enddo
+
+ do m = 1,miner
+ do k = 0,lsym_v(m)
+
+c-------------Group III: L = m+2*k,
+c-------------FUA = FUA - (r_on dfv2b/[L(L+1)] + fv2a)
+c-------------FUB = FUB - r_on fv1/[L(L+1)]
+c-------------Group IV: L = m+2*k+1,
+c-------------FUA = FUA - r_on fv1/[L(L+1)]
+c-------------FUB = FUB - (r_on dfv2b/[L(L+1)] + fv2a)
+
+ L1 = m+2*k
+ L2 = m+2*k+1
+ Lcc1= kdm(m-1)+2*k*nmxo1+i+1
+ Lcc2= kdm(m-1)+(2*k+1)*nmxo1+i+1
+ c1 = ron/LL(L1)
+ c2 = ron/LL(L2)
+ fua(Lcc1)= fua(Lcc1)-c1*dfv2b(L1,m+1,i)-fv2a(L1,m+1,i)
+ fua(Lcc2)= fua(Lcc2)-c2*fv1(L2,m+1,i)
+ fub(Lcc1)= fub(Lcc1)-c1*fv1(L1,m+1,i)
+ fub(Lcc2)= fub(Lcc2)-c2*dfv2b(L2,m+1,i)-fv2a(L2,m+1,i)
+
+ enddo
+ enddo
+
+ enddo
+
+c
+c-------[2.6] EVALUATING THE FORCES (FB,FJ,FT,FC) IN THE OUTER CORE
+c
+
+c-------fb(i) = 1/2 [gg(i) fb1(i) + gg(i+1) fb1(i+1)]/L(L+1)
+c-------fj(i) = 1/2 [gg(i) fb2a(i)+ gg(i+1) fb2a(i+1)]
+c------- + 1/12 h^{-1} [fb2b(i+2) + 9 fb2b(i+1)
+c------- - 9 fb2b(i) - fb2b(i-1)]/L(L+1)
+c-------ft(i) = 1/2 {gg(i) [ft1(i)+aj*qj(i)] + gg(i+1) [ft1(i+1)+aj*qj(i+1)]}
+
+ do L = 1,Lmax_m
+ c1 = 1.0/(2.0*LL(L))
+ c2 = hn1/(12.0*LL(L))
+ do i = 2,nmaxo-3
+ k = nmbic+2*i+3
+ fb(k,L,0) = c1*(fb1(L,0,i)*gg(i)+fb1(L,0,i+1)*gg(i+1))
+ fj(k,L,0) = 0.5*(fb2a(L,0,i)*gg(i)+fb2a(L,0,i+1)*gg(i+1))
+ & +c2*(fb2b(L,0,i+2)+9.0*fb2b(L,0,i+1)-
+ & 9.0*fb2b(L,0,i)-fb2b(L,0,i-1))
+ enddo
+ c1 = 1.0/(1.0*LL(L))
+ i = 0
+ k = nmbic+2*i+3
+ fb(k,L,0) = c1*(cfm(4,3)*fb1(L,0,i)+cfm(5,3)*fb1(L,0,i+1))
+ fj(k,L,0) = (cfm(4,3)*fb2a(L,0,i)+cfm(5,3)*fb2a(L,0,i+1))
+ & +c1*(cfm(1,3)*fb2b(L,0,i)+cfm(2,3)*fb2b(L,0,i+1)
+ & +cfm(3,3)*fb2b(L,0,i+2))
+ i = 1
+ k = nmbic+2*i+3
+ fb(k,L,0) = c1*(cfm(4,4)*fb1(L,0,i)+cfm(5,4)*fb1(L,0,i+1))
+ fj(k,L,0) = (cfm(4,4)*fb2a(L,0,i)+cfm(5,4)*fb2a(L,0,i+1))
+ & +c1*(cfm(1,4)*fb2b(L,0,i)+cfm(2,4)*fb2b(L,0,i+1)
+ & +cfm(3,4)*fb2b(L,0,i+2))
+ i = nmaxo-2
+ k = nmbic+2*i+3
+ fb(k,L,0) = c1*(cfm(4,5)*fb1(L,0,i)+cfm(5,5)*fb1(L,0,i+1))
+ fj(k,L,0) = (cfm(4,5)*fb2a(L,0,i)+cfm(5,5)*fb2a(L,0,i+1))
+ & +c1*(cfm(1,5)*fb2b(L,0,i)+cfm(2,5)*fb2b(L,0,i+1)
+ & +cfm(3,5)*fb2b(L,0,i+2))
+ i = nmaxo-1
+ k = nmbic+2*i+3
+ fb(k,L,0) = c1*(cfm(4,6)*fb1(L,0,i)+cfm(5,6)*fb1(L,0,i+1))
+ fj(k,L,0) = (cfm(4,6)*fb2a(L,0,i)+cfm(5,6)*fb2a(L,0,i+1))
+ & +c1*(cfm(1,6)*fb2b(L,0,i-1)+cfm(2,6)*fb2b(L,0,i)
+ & +cfm(3,6)*fb2b(L,0,i+1))
+ enddo
+
+ do m = 1,mmax_m
+ do L = m,Lmax_m
+ c1= 1.0/(2.0*LL(L))
+ c2= hn1/(12.0*LL(L))
+ do i = 2,nmaxo-3
+ k = nmbic+2*i+3
+ fb(k,L,m) = c1*(fb1(L,m,i)*gg(i)+fb1(L,m,i+1)*
+ & gg(i+1))
+ fj(k,L,m) = 0.5*(fb2a(L,m,i)*gg(i)+fb2a(L,m,i+1)
+ & *gg(i+1))+c2*(fb2b(L,m,i+2)+9.0*
+ & fb2b(L,m,i+1)-9.0*fb2b(L,m,i)-
+ & fb2b(L,m,i-1))
+ enddo
+ c1= 1.0/(1.0*LL(L))
+ i = 0
+ k = nmbic+2*i+3
+ fb(k,L,m) = c1*(cfm(4,3)*fb1(L,m,i)+cfm(5,3)*fb1(L,m,i+1))
+ fj(k,L,m) = (cfm(4,3)*fb2a(L,m,i)+cfm(5,3)*fb2a(L,m,i+1))
+ & +c1*(cfm(1,3)*fb2b(L,m,i)+cfm(2,3)*
+ & fb2b(L,m,i+1)+cfm(3,3)*fb2b(L,m,i+2))
+ i = 1
+ k = nmbic+2*i+3
+ fb(k,L,m) = c1*(cfm(4,4)*fb1(L,m,i)+cfm(5,4)*fb1(L,m,i+1))
+ fj(k,L,m) = (cfm(4,4)*fb2a(L,m,i)+cfm(5,4)*fb2a(L,m,i+1))
+ & +c1*(cfm(1,4)*fb2b(L,m,i)+cfm(2,4)*
+ & fb2b(L,m,i+1)+cfm(3,4)*fb2b(L,m,i+2))
+ i = nmaxo-2
+ k = nmbic+2*i+3
+ fb(k,L,m) = c1*(cfm(4,5)*fb1(L,m,i)+cfm(5,5)*fb1(L,m,i+1))
+ fj(k,L,m) = (cfm(4,5)*fb2a(L,m,i)+cfm(5,5)*fb2a(L,m,i+1))
+ & +c1*(cfm(1,5)*fb2b(L,m,i)+cfm(2,5)*
+ & fb2b(L,m,i+1)+cfm(3,5)*fb2b(L,m,i+2))
+ i = nmaxo-1
+ k = nmbic+2*i+3
+ fb(k,L,m) = c1*(cfm(4,6)*fb1(L,m,i)+cfm(5,6)*fb1(L,m,i+1))
+ fj(k,L,m) = (cfm(4,6)*fb2a(L,m,i)+cfm(5,6)*fb2a(L,m,i+1))
+ & +c1*(cfm(1,6)*fb2b(L,m,i-1)+cfm(2,6)*
+ & fb2b(L,m,i)+cfm(3,6)*fb2b(L,m,i+1))
+ enddo
+ enddo
+
+ do m = 0,mmax_t
+ do L = m,Lmax_t
+ do i = 2,nmaxo-3
+ ft(2*i+3,L,m) = 0.5*(gg(i)*(ft1(i,L,m)+aj*
+ & qj(i,L,m))+gg(i+1)*
+ & (ft1(i+1,L,m)+aj*qj(i+1,L,m)))
+ enddo
+ i = 0
+ ft(2*i+3,L,m) = cfm(4,3)*(ft1(i,L,m)+aj*qj(i,L,m))+
+ & cfm(5,3)*(ft1(i+1,L,m)+aj*qj(i+1,L,m))
+ i = 1
+ ft(2*i+3,L,m) = cfm(4,4)*(ft1(i,L,m)+aj*qj(i,L,m))+
+ & cfm(5,4)*(ft1(i+1,L,m)+aj*qj(i+1,L,m))
+ i = nmaxo-2
+ ft(2*i+3,L,m) = cfm(4,5)*(ft1(i,L,m)+aj*qj(i,L,m))+
+ & cfm(5,5)*(ft1(i+1,L,m)+aj*qj(i+1,L,m))
+ i = nmaxo-1
+ ft(2*i+3,L,m) = cfm(4,6)*(ft1(i,L,m)+aj*qj(i,L,m))+
+ & cfm(5,6)*(ft1(i+1,L,m)+aj*qj(i+1,L,m))
+ enddo
+ enddo
+
+c
+c-------[2.7] BOUNDARY CONDITIONS FOR (coua,coub,cot,coc)
+c
+
+ do L1 = 1,lsym_v(0)
+ k1 = 2*(L1-1)*nmxo1
+ k2 = (2*L1-1)*nmxo1
+ fua(k1+1) = 0.0
+ fua(k1+2) = 0.0
+ fua(k1+nmaxo)= 0.0
+ fua(k1+nmxo1)= 0.0
+ fub(k1+1) = 0.0
+ fub(k1+nmxo1)= 0.0
+ fua(k2+1) = 0.0
+ fua(k2+nmxo1)= 0.0
+ fub(k2+1) = 0.0
+ fub(k2+2) = 0.0
+ fub(k2+nmaxo)= 0.0
+ fub(k2+nmxo1)= 0.0
+ enddo
+
+ do m = 1,miner
+ do L1= 0,lsym_v(m)
+ k1= kdm(m-1)+2*L1*nmxo1
+ k2= kdm(m-1)+(2*L1+1)*nmxo1
+ fua(k1+1) = 0.0
+ fua(k1+2) = 0.0
+ fua(k1+nmaxo)= 0.0
+ fua(k1+nmxo1)= 0.0
+ fub(k1+1) = 0.0
+ fub(k1+nmxo1)= 0.0
+ fua(k2+1) = 0.0
+ fua(k2+nmxo1)= 0.0
+ fub(k2+1) = 0.0
+ fub(k2+2) = 0.0
+ fub(k2+nmaxo)= 0.0
+ fub(k2+nmxo1)= 0.0
+ enddo
+ enddo
+
+ ft(1,:,:) = 0.0
+ ft(nmx3,:,:) = 0.0
+
+C
+C PART III: EVALUATING THE FORCES (GZI,GZM,GHI,GHM) FOR ROTATIONS
+C OF THE INNER CORE AND THE MANTLE
+C
+
+c
+c (3.1) The Lorent torque on the boundaries
+c
+
+ if (kicbb .eq. 2) then
+
+c The Lorentz torque on the ICB
+
+ tmpr1 = 0.0
+ tmpr1 = br(:,:,0)*bph(:,:,0)
+ call zfspht(tmpr1,aslg,gauwt,table,Lmaxa,mmaxa,ntmax,
+ & npmax,tmpc1)
+
+ torqb(1)= sqrt(4.0*pi)*real(tmpc1(0,0))
+
+ tmpr1= 0.0
+ do k = 1,ntmax
+ tmpr1(:,k) = br(:,k,0)*bth(:,k,0)/sins(k)**2
+ enddo
+
+ call zfspht(tmpr1,aslg,gauwt,table,Lmaxa,mmaxa,ntmax,
+ & npmax,tmpc1)
+
+ torqb(2)= sqrt(8.0*pi/3.0)*ui*tmpc1(1,1)
+
+ tmpr1= 0.0
+ do k = 1,ntmax
+ tmpr1(:,k) = br(:,k,0)*bph(:,k,0)*th(k)/sins(k)**2
+ enddo
+
+ call zfspht(tmpr1,aslg,gauwt,table,Lmaxa,mmaxa,ntmax,
+ & npmax,tmpc1)
+
+ torqb(3)= sqrt(8.0*pi/3.0)*tmpc1(1,1)
+
+ gzi = cm*torqb(1)
+ ghi = cm*conjg(torqb(2)+torqb(3))
+
+ endif
+
+ if (kcmbb .eq. 2) then
+
+c The Lorentz torque on the CMB
+
+ tmpr1 = br(:,:,nmaxo)
+
+c Consider the CMB topography effect
+
+ tmpr2= 0.0
+ tmpr2= tmpr1*bph(:,:,nmaxo)
+ call zfspht(tmpr2,aslg,gauwt,table,Lmaxa,mmaxa,ntmax,
+ & npmax,tmpc1)
+
+ torqb(4)= -sqrt(4.0*pi)*real(tmpc1(0,0))
+
+ tmpr2= 0.0
+ do k = 1,ntmax
+ tmpr2(:,k) = tmpr1(:,k)*bth(:,k,nmaxo)
+ & /sins(k)**2
+ enddo
+
+ call zfspht(tmpr2,aslg,gauwt,table,Lmaxa,mmaxa,ntmax,
+ & npmax,tmpc1)
+
+ torqb(5)= -sqrt(8.0*pi/3.0)*ui*tmpc1(1,1)
+
+ tmpr2= 0.0
+ do k = 1,ntmax
+ tmpr2(:,k) = tmpr1(:,k)*bph(:,k,nmaxo)*th(k)
+ & /sins(k)**2
+ enddo
+
+ call zfspht(tmpr2,aslg,gauwt,table,Lmaxa,mmaxa,ntmax,
+ & npmax,tmpc1)
+
+ torqb(6)= -sqrt(8.0*pi/3.0)*tmpc1(1,1)
+
+ gzm = cm*torqb(4)
+ ghm = cm*conjg(torqb(5)+torqb(6))
+
+ endif
+
+c
+c (3.2) The viscous torque with no "stress-free" boundary conditions
+c
+
+ if (kicbv .ge. 1) then
+
+c The viscous torque on the ICB
+
+ torqv(1)= 4.0*sqrt(pi/3.0)*rio**2*
+ & real(dsw(1,0,0)-2*sw(1,0,0)/rio)
+
+ tmpc1= 0.0
+ m = 1
+ uim = cmplx(0.0,1.0*m)
+ do L = m+1,Lmax
+ tmpc1(L,m) = uim*(dsw(L,m,0)-2*sw(L,m,0)/rio)+
+ & clm(L,m,1)*(d2sv(L-1,m,0)-2*dsv(L-1,m,0)/rio)
+ & -clm(L,m,2)*(d2sv(L+1,m,0)-2*dsv(L+1,m,0)/rio)
+ enddo
+ tmpc1(m,m) = uim*(dsw(m,m,0)-2*sw(m,m,0)/rio)-
+ & clm(m,m,2)*(d2sv(m+1,m,0)-2*dsv(m+1,m,0)/rio)
+ call izfspht(tmpc1,aslg,table,Lmaxa,mmaxa,ntmax,
+ & npmax,tmpr1)
+ do k = 1,ntmax
+ c1 = (rio/sins(k))**2
+ tmpr1(:,k) = c1*tmpr1(:,k)
+ enddo
+ call zfspht(tmpr1,aslg,gauwt,table,Lmaxa,mmaxa,ntmax,
+ & npmax,tmpc1)
+ torqv(2)= ui*sqrt(8.0*pi/3.0)*tmpc1(1,1)
+
+ tmpc1= 0.0
+ m = 1
+ uim = cmplx(0.0,1.0*m)
+ do L = m+1,Lmax
+ tmpc1(L,m) = uim*(d2sv(L,m,0)-2*dsv(L,m,0)/rio)-
+ & clm(L,m,1)*(dsw(L-1,m,0)-2*sw(L-1,m,0)/rio)+
+ & clm(L,m,2)*(dsw(L+1,m,0)-2*sw(L+1,m,0)/rio)
+ enddo
+ tmpc1(m,m) = uim*(d2sv(m,m,0)-2*dsv(m,m,0)/rio)+
+ & clm(m,m,2)*(dsw(m+1,m,0)-2*sw(m+1,m,0)/rio)
+ call izfspht(tmpc1,aslg,table,Lmaxa,mmaxa,ntmax,
+ & npmax,tmpr1)
+ do k = 1,ntmax
+ c1 = (rio/sins(k))**2
+ tmpr1(:,k) = c1*tmpr1(:,k)
+ enddo
+ call zfspht(tmpr1,aslg,gauwt,table,Lmaxa,mmaxa,ntmax,
+ & npmax,tmpc1)
+ torqv(3)= sqrt(8.0*pi/15.0)*tmpc1(2,1)
+
+ gzi = gzi+ekman*torqv(1)
+ ghi = ghi+ekman*conjg(torqv(2)+torqv(3))
+
+ endif
+
+ if (kcmbv .ge. 1) then
+
+c The viscous torque on the CMB
+
+ torqv(4)= -4.0*sqrt(pi/3.0)*
+ & real(dsw(1,0,nmaxo)-2*sw(1,0,nmaxo))
+
+ tmpc1= 0.0
+ m = 1
+ k = nmaxo
+ uim = cmplx(0.0,1.0*m)
+ do L = m+1,Lmax
+ tmpc1(L,m) = uim*(dsw(L,m,k)-2.0*sw(L,m,k))+
+ & clm(L,m,1)*(d2sv(L-1,m,k)-2.0*dsv(L-1,m,k))-
+ & clm(L,m,2)*(d2sv(L+1,m,k)-2.0*dsv(L+1,m,k))
+ enddo
+ tmpc1(m,m) = uim*(dsw(m,m,k)-2.0*sw(m,m,k))-
+ & clm(m,m,2)*(d2sv(m+1,m,k)-2.0*dsv(m+1,m,k))
+ call izfspht(tmpc1,aslg,table,Lmaxa,mmaxa,ntmax,
+ & npmax,tmpr1)
+ do k = 1,ntmax
+ c1 = 1.0/sins(k)**2
+ tmpr1(:,k) = c1*tmpr1(:,k)
+ enddo
+ call zfspht(tmpr1,aslg,gauwt,table,Lmaxa,mmaxa,ntmax,
+ & npmax,tmpc1)
+ torqv(5)= -ui*sqrt(8.0*pi/3.0)*tmpc1(1,1)
+
+ tmpc1= 0.0
+ m = 1
+ k = nmaxo
+ uim = cmplx(0.0,1.0*m)
+ do L = m+1,Lmax
+ tmpc1(L,m) = uim*(d2sv(L,m,k)-2*dsv(L,m,k))
+ & -clm(L,m,1)*(dsw(L-1,m,k)-2*sw(L-1,m,k))+
+ & clm(L,m,2)*(dsw(L+1,m,k)-2*sw(L+1,m,k))
+ enddo
+ tmpc1(m,m) = uim*(d2sv(m,m,k)-2*dsv(m,m,k))+
+ & clm(m,m,2)*(dsw(m+1,m,k)-2*sw(m+1,m,k))
+ call izfspht(tmpc1,aslg,table,Lmaxa,mmaxa,ntmax,
+ & npmax,tmpr1)
+ do k = 1,ntmax
+ c1 = 1.0/sins(k)**2
+ tmpr1(:,k) = c1*tmpr1(:,k)
+ enddo
+ call zfspht(tmpr1,aslg,gauwt,table,Lmaxa,mmaxa,ntmax,
+ & npmax,tmpc1)
+ torqv(6)= -sqrt(8.0*pi/15.0)*tmpc1(2,1)
+
+ gzm = gzm+ekman*torqv(4)
+ ghm = ghm+ekman*conjg(torqv(5)+torqv(6))
+
+ endif
+
+c
+c (3.3) The pressure torque with boundary topographies at the CMB
+c
+
+!
+! (3.4) Add gravitational coupling torque on the mantle
+!
+
+C
+C PART IV: OBTAINGIN THE FORCES (FB,FJ) IN THE INNER CORE AND IN
+C THE D" LAYER
+C
+
+ fbi1 = 0.0
+ fbi2a = 0.0
+ fbi2b = 0.0
+ fbm1 = 0.0
+ fbm2a = 0.0
+ fbm2b = 0.0
+
+c
+c (4.1) Obtaining the forces in the inner core
+c
+
+ if (kicbb .eq. 2) then
+
+ call force_ic(fbi1,fbi2a,fbi2b,c1)
+
+ if (c1 .lt. cflno) cflno = c1
+
+ do m = 0,mmax_m
+ do L = m,Lmax_m
+ do i = 1,nmaxi-3
+ k = 2*i+3
+ fb(k,L,m) = 0.5*(gi(i)*fbi1(L,m,i)+gi(i+1)*
+ & fbi1(L,m,i+1))
+ fj(k,L,m) = 0.5*(gi(i)*fbi2a(L,m,i)+gi(i+1)*
+ & fbi2a(L,m,i+1))+hni1*(fbi2b(L,m,i+2)
+ & +9.0*fbi2b(L,m,i+1)-9.0*fbi2b(L,m,i)
+ & -fbi2b(L,m,i-1))/12.0
+ enddo
+ i = 0
+ k = 2*i+3
+ fb(k,L,m) = (gi(i)*fbi1(L,m,i)+4.0*gi(i+1)*
+ & fbi1(L,m,i+1)+gi(i+2)*fbi1(L,m,i+2))
+ & /6.0
+ fj(k,L,m) = (gi(i)*fbi2a(L,m,i)+4.0*gi(i+1)*
+ & fbi2a(L,m,i+1)+gi(i+2)*fbi2a(L,m,i+2))
+ & /6.0+0.5*hni1*(fbi2b(L,m,i+2)-
+ & fbi2b(L,m,i))
+ i = nmaxi-2
+ k = 2*i+3
+ fb(k,L,m) = cfm(4,1)*fbi1(L,m,i)+cfm(5,1)*
+ & fbi1(L,m,i+1)
+ fj(k,L,m) = (cfm(4,1)*fbi2a(L,m,i)+cfm(5,1)*
+ & fbi2a(L,m,i+1))+(cfm(1,1)*fbi2b(L,m,i)+
+ & cfm(2,1)*fbi2b(L,m,i+1)+cfm(3,1)*
+ & fbi2b(L,m,i+2))
+ i = nmaxi-1
+ k = 2*i+3
+ fb(k,L,m) = cfm(4,2)*fbi1(L,m,i)+cfm(5,2)*
+ & fbi1(L,m,i+1)
+ fj(k,L,m) = (cfm(4,2)*fbi2a(L,m,i)+cfm(5,2)*
+ & fbi2a(L,m,i+1))+(cfm(1,2)*fbi2b(L,m,i-1)
+ & +cfm(2,2)*fbi2b(L,m,i)+cfm(3,2)*
+ & fbi2b(L,m,i+1))
+ enddo
+ enddo
+
+ endif
+
+c
+c (4.2) Obtaining the forces in the D"-layer
+c
+
+ if (kcmbb .eq. 2) then
+
+ call force_dp(fbm1,fbm2a,fbm2b)
+
+ do m = 0,mmax_m
+ do L = m,Lmax_m
+ do i = 2,nmaxm-2
+ k = nmx3+nmbic+2*i+3
+ fb(k,L,m) = 0.5*(gd(i)*fbm1(L,m,i)+gd(i+1)*
+ & fbm1(L,m,i+1))
+ fj(k,L,m) = 0.5*(gd(i)*fbm2a(L,m,i)+gd(i+1)*
+ & fbm2a(L,m,i+1))+hnm1*(fbm2b(L,m,i+2)
+ & +9.0*fbm2b(L,m,i+1)-9.0*fbm2b(L,m,i)
+ & -fbm2b(L,m,i-1))/12.0
+ enddo
+ i = 0
+ k = nmx3+nmbic+2*i+3
+ fb(k,L,m) = cfm(4,7)*fbm1(L,m,i)+cfm(5,7)*
+ & fbm1(L,m,i+1)
+ fj(k,L,m) = (cfm(4,7)*fbm2a(L,m,i)+cfm(5,7)*
+ & fbm2a(L,m,i+1))+(cfm(1,7)*fbm2b(L,m,i)
+ & +cfm(2,7)*fbm2b(L,m,i+1)+cfm(3,7)*
+ & fbm2b(L,m,i+2))
+ i = 1
+ k = nmx3+nmbic+2*i+3
+ fb(k,L,m) = cfm(4,8)*fbm1(L,m,i)+cfm(5,8)*
+ & fbm1(L,m,i+1)
+ fj(k,L,m) = (cfm(4,8)*fbm2a(L,m,i)+cfm(5,8)*
+ & fbm2a(L,m,i+1))+(cfm(1,8)*fbm2b(L,m,i)
+ & +cfm(2,8)*fbm2b(L,m,i+1)+cfm(3,8)*
+ & fbm2b(L,m,i+2))
+ i = nmaxm-1
+ k = nmx3+nmbic+2*i+3
+ fb(k,L,m) = (gd(i-1)*fbm1(L,m,i-1)+4.0*gd(i)*
+ & fbm1(L,m,i)+gd(i+1)*fbm1(L,m,i+1))
+ & /6.0
+ fj(k,L,m) = (gd(i-1)*fbm2a(L,m,i-1)+4.0*gd(i)*
+ & fbm2a(L,m,i)+gd(i+1)*fbm2a(L,m,i+1))
+ & /6.0+0.5*hnm1*(fbm2b(L,m,i+1)-
+ & fbm2b(L,m,i-1))
+ enddo
+ enddo
+
+ endif
+
+c
+c-------[4.3] THE BOUNDARY CONDITIONS FOR THE MAGNETIC FIELD (cob,coj)
+c
+
+c
+c-------[4.3.1] Near the center
+c
+
+ fb(1,:,:) = 0.0
+ fj(1,:,:) = 0.0
+
+c
+c-------[4.3.2] At the perfectly insulating mantle (D"-mantle boundary)
+c
+
+ fb(nmb,:,:) = 0.0
+ fj(nmb,:,:) = 0.0
+
+c
+c-------[4.3.3] At the ICB
+c
+
+ if (kicbb .le. 1) then
+ fb(nmbic+1,:,:)= 0.0
+ fj(nmbic+1,:,:)= 0.0
+ else if (kicbb .eq. 2) then
+ fb(nmbic,:,:) = 0.0
+ fj(nmbic,:,:) = 0.0
+ fb(nmbic+1,:,:)= 0.0
+ endif
+
+c
+c-------[4.3.4] At the CMB
+c
+
+ k = nmx3+nmbic
+ if (kcmbb .le. 1) then
+ fb(k,:,:) = 0.0
+ fj(k,:,:) = 0.0
+ else if (kcmbb .eq. 2) then
+ fb(k,:,:) = 0.0
+ fb(k+1,:,:)= 0.0
+ fj(k+1,:,:)= 0.0
+ endif
+
+ return
+ end
+
+
+*************************************************************************
+*************************************************************************
+
+ subroutine force_ic(fb1,fb2a,fb2b,cfl_ic)
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+c This subroutine calculate the force CURL (V X B) in the inner
+c core. All rotations (axial + horizontal) are included.
+c
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ use mod_dimparam
+ use mod_sysparam
+ use mod_optparam
+
+ use mod_radgeom
+ use mod_sphgeom
+
+ use mod_bfield
+ use mod_rotation
+
+ implicit none
+
+ real (kind=8) cfl_ic
+
+ complex (kind=8), dimension(0:Lmax,0:mmax,0:nmaxi) :: fb1,
+ & fb2a,fb2b
+
+ integer idamax
+ integer i,k,L,m,k1,k2
+ real (kind=8) c1,dhp
+ complex (kind=8) ui,uim
+
+ real (kind=8) tmpr4(ntmax)
+ real (kind=8), dimension(npmax,ntmax) :: br,bth,bph,vth,
+ & vph,tmpr1,tmpr2,tmpr3
+
+ complex (kind=8), dimension(0:Lmax1,0:mmax,0:nmaxi) :: sb,
+ & dsb,sj
+ complex (kind=8), dimension(0:Lmaxa,0:mmaxa) :: tmpc1,
+ & tmpc2,tmpc3
+
+c
+c Subroutine strats here
+c
+
+ ui = cmplx(0.0,1.0)
+
+ fb1 = 0.0
+ fb2a = 0.0
+ fb2b = 0.0
+
+ if (kicbb .lt. 2) return
+
+c
+c-------[1] Oibtaining the horizontal flow [ r sin(th) (v_th, v_ph)/r^2]
+c [generated by (omgih,omgiz)] at the collocation points
+c
+
+ tmpc1 = 0.0
+ tmpc1(1,1)= -ui*sqrt(2.0*pi/3.0)*conjg(omgih)
+
+ call izfspht(tmpc1,aslg,table,Lmaxa,mmaxa,ntmax,
+ & npmax,vth)
+
+ tmpc1 = 0.0
+ tmpc1(0,0)= 4.0*sqrt(pi)*omgiz/3.0
+ tmpc1(2,0)= -4.0*sqrt(pi/5.0)*omgiz/3.0
+ tmpc1(2,1)= sqrt(2.0*pi/15.0)*conjg(omgih)
+
+ call izfspht(tmpc1,aslg,table,Lmaxa,mmaxa,ntmax,
+ & npmax,vph)
+
+
+c
+c-------[2] Obtaining [ (1, d/dr) b_l^m, j_l^m] for the inner core
+c
+
+ do i = 0,nmaxi
+
+ sb(:,:,i) = 0.0
+ dsb(:,:,i) = 0.0
+ sj(:,:,i) = 0.0
+
+ k1 = 2*i+1
+ k2 = 2*i+2
+
+ do L = 1,Lmax_m
+ sb(L,0,i) = cob(k1,L,0)
+ dsb(L,0,i) = cob(k2,L,0)
+ sj(L,0,i) = coj(k1,L,0)
+ enddo
+ do m = 1,mmax_m
+ do L = m,Lmax_m
+ sb(L,m,i) = cob(k1,L,m)
+ dsb(L,m,i) = cob(k2,L,m)
+ sj(L,m,i) = coj(k1,L,m)
+ enddo
+ enddo
+
+ enddo
+
+c
+c-------[3] OBTAINING THE FORCE (FB,FJ) IN THE INNER CORE
+c
+
+ do i = 0,nmaxi
+
+c----------[3.1] the value of [r^2 b_r, r sin(th) (b_th, b_ph)]
+c---------- at the collocation points
+
+ tmpc1 = 0.0
+ tmpc2 = 0.0
+ tmpc3 = 0.0
+
+ do m = 0,mmax
+ tmpc1(m:Lmax,m)= LL(m:Lmax)*sb(m:Lmax,m,i)
+ enddo
+
+ do m = 0,mmax
+ uim = cmplx(0.0,1.0*m)
+ do L = m+1,Lmax
+ tmpc2(L,m) = uim*sj(L,m,i)+clm(L,m,1)*dsb(L-1,m,i)
+ & -clm(L,m,2)*dsb(L+1,m,i)
+ tmpc3(L,m) = uim*dsb(L,m,i)-clm(L,m,1)*sj(L-1,m,i)
+ & +clm(L,m,2)*sj(L+1,m,i)
+ enddo
+ tmpc2(m,m) = uim*sj(m,m,i)-clm(m,m,2)*dsb(m+1,m,i)
+ tmpc3(m,m) = uim*dsb(m,m,i)+clm(m,m,2)*sj(m+1,m,i)
+ enddo
+
+ call izfspht(tmpc1,aslg,table,Lmaxa,mmaxa,ntmax,
+ & npmax,br)
+ call izfspht(tmpc2,aslg,table,Lmaxa,mmaxa,ntmax,
+ & npmax,bth)
+ call izfspht(tmpc3,aslg,table,Lmaxa,mmaxa,ntmax,
+ & npmax,bph)
+
+c----------[3.2] the inverse transform of CURL (V X B)
+
+c----------the terms A1 = [r sin(th) v_th] (r^2 b_r)/[r^2 sin(th)^2]; (tmpc1)
+c----------the terms A2 = [r sin(th) v_ph] (r^2 b_r)/[r^2 sin(th)^2]; (tmpc2)
+c----------the terms A3 = {[r sin(th) v_th][r sin(th) b_ph]-
+c---------- [r sin(th) v_ph][r sin(th) b_th]}/[r^2 sin(th)^2]; (tmpc3)
+
+ do k = 1,ntmax
+ c1=1.0/sins(k)**2
+ tmpr1(:,k) = c1*vth(:,k)*br(:,k)
+ tmpr2(:,k) = c1*vph(:,k)*br(:,k)
+ tmpr3(:,k) = c1*(vth(:,k)*bph(:,k)-vph(:,k)*bth(:,k))
+ enddo
+
+ call zfspht(tmpr1,aslg,gauwt,table,Lmaxa,mmaxa,ntmax,
+ & npmax,tmpc1)
+ call zfspht(tmpr2,aslg,gauwt,table,Lmaxa,mmaxa,ntmax,
+ & npmax,tmpc2)
+ call zfspht(tmpr3,aslg,gauwt,table,Lmaxa,mmaxa,ntmax,
+ & npmax,tmpc3)
+
+c----------the forces:
+c----------fb1 = -[sin(th) d/dth + 2 cos(th)] A1 - d/dph A2;
+c----------fb2a= A3
+c----------fb2b= [sin(th) d/dth + 2 cos(th)] A2 - d/dph A1;
+
+ do m = 0,mmax
+ uim = cmplx(0.0,1.0*m)
+ do L = m+1,Lmax
+ fb1(L,m,i) = -uim*tmpc2(L,m)-clm(L,m,3)*
+ & tmpc1(L-1,m)+clm(L,m,4)*tmpc1(L+1,m)
+ fb2b(L,m,i)= -uim*tmpc1(L,m)+clm(L,m,3)*
+ & tmpc2(L-1,m)-clm(L,m,4)*tmpc2(L+1,m)
+ enddo
+ fb1(m,m,i) = -uim*tmpc2(m,m)+clm(m,m,4)*tmpc1(m+1,m)
+ fb2b(m,m,i)= -uim*tmpc1(m,m)-clm(m,m,4)*tmpc2(m+1,m)
+ enddo
+
+ do m = 0,mmax
+ fb2a(m:Lmax,m,i) = tmpc3(m:Lmax,m)
+ enddo
+
+ do L = 1,Lmax
+ fb1(L,0,i) = fb1(L,0,i)/(1.0*LL(L))
+ fb2b(L,0,i)= fb2b(L,0,i)/(1.0*LL(L))
+ enddo
+ do m = 1,mmax
+ do L = m,Lmax
+ c1 = 1.0/(1.0*LL(L))
+ fb1(L,m,i) = fb1(L,m,i)*c1
+ fb2b(L,m,i)= fb2b(L,m,i)*c1
+ enddo
+ enddo
+
+ enddo
+
+
+c
+c-------[4] THE CFL CONDITION IN THE INNER CORE
+c
+
+ dhp = 2.0*pi/npmax
+
+ tmpr1 = 0.0
+ do k = 1,ntmax
+ c1 = 1.0/sins(k)
+ tmpr1(:,k) = abs(vth(:,k)*c1*dhp)+abs(vph(:,k)/dht(k))
+ enddo
+
+ tmpr4 = 0.0
+ do k = 1,ntmax
+ k1 = idamax(npmax,tmpr1(1,k),1)
+ tmpr4(k) = tmpr1(k1,k)
+ enddo
+
+ c1 = 0.0
+ do m = 0,mmax
+ do L = m,Lmax
+ c1= c1+LL(L)*(abs(sj(L,m,nmaxi)*sj(L,m,nmaxi))+
+ & abs(dsb(L,m,nmaxi)*dsb(L,m,nmaxi)))
+ enddo
+ enddo
+
+ k1 = idamax(ntmax,tmpr4(1),1)
+
+ c1 = abs(tmpr4(k1))+sqrt(tmpr4(k1)**2+2.0*c1/(ro*mti))
+
+ cfl_ic = 0.5/c1
+
+
+ return
+ end
+
+
+*************************************************************************
+*************************************************************************
+
+ subroutine force_dp(fb1,fb2a,fb2b)
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+c This subroutine calculate the force arising from anomalies
+c in the D"-layer.
+c
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ use mod_dimparam
+ use mod_sysparam
+ use mod_optparam
+
+ use mod_radgeom
+ use mod_sphgeom
+
+ use mod_bfield
+ use mod_rotation
+
+ implicit none
+
+ complex (kind=8), dimension(0:Lmax,0:mmax,0:nmaxm) :: fb1,
+ & fb2a,fb2b
+
+ complex (kind=8) ui
+
+c
+c Subroutine starts here
+c
+
+ ui = cmplx(0.0,1.0)
+
+ fb1 = 0.0
+ fb2a = 0.0
+ fb2b = 0.0
+
+ if (kcmbb .lt. 2) return
+
+ return
+ end
+
Property changes on: geodyn/3D/MoSST/trunk/forces.f
___________________________________________________________________
Name: svn:executable
+
Added: geodyn/3D/MoSST/trunk/matrices.f
===================================================================
--- geodyn/3D/MoSST/trunk/matrices.f 2006-10-23 16:55:10 UTC (rev 5079)
+++ geodyn/3D/MoSST/trunk/matrices.f 2006-10-23 20:50:23 UTC (rev 5080)
@@ -0,0 +1,41 @@
+c
+c This subroutine provides matrices for the equations
+c The subroutines are used for Sun workstations
+c W.Kuang: 02/2001
+c
+
+
+*************************************************************************
+*************************************************************************
+
+ subroutine matrices
+
+ use mod_optparam
+
+ use mod_vmatrix
+ use mod_bmatrix
+ use mod_tmatrix
+
+C SUBROUTINE STARTS HERE
+
+ itrung = 0
+
+c Determining (CVA,CVB)
+
+ call vmatrixv
+
+c Determining (CUA1,CUA2,CUB1,CUB2)
+
+ call vmatrixu
+
+c Determining (CB1,CB2,CJ1,CJ2)
+
+ call bmatrix
+
+c Determining (CT1,CT2)
+
+ call tmatrix
+
+ return
+ end
+
Property changes on: geodyn/3D/MoSST/trunk/matrices.f
___________________________________________________________________
Name: svn:executable
+
Added: geodyn/3D/MoSST/trunk/miscs.f
===================================================================
--- geodyn/3D/MoSST/trunk/miscs.f 2006-10-23 16:55:10 UTC (rev 5079)
+++ geodyn/3D/MoSST/trunk/miscs.f 2006-10-23 20:50:23 UTC (rev 5080)
@@ -0,0 +1,377 @@
+c
+c This group of subroutines provide supportive functions for
+c the model.
+c These subroutines are for Sun workstations with Sun Performance
+c Library.
+c W.Kuang: 08/99
+c
+
+*************************************************************************
+*************************************************************************
+
+ subroutine energy(amv,amb,amt,elv,elb,elt)
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+c This subroutine evaluates the L^2-norm of the velocity field,
+c the magnetic field, the temperature field
+c
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ use mod_dimparam
+ use mod_sysparam
+
+ use mod_parity
+ use mod_radgeom
+ use mod_sphgeom
+
+ use mod_vfield
+ use mod_bfield
+ use mod_tfield
+
+ implicit none
+
+ real (kind=8) amv,amw,amb,amj,amt,amh,elv,elb,elt
+
+ integer i,k,k1,k2,L,m,n
+ real (kind=8) dznrm2,dasum,one
+ real (kind=8) c1,c2,c3,c4,d1,d2,d3,d4,d5,vol
+
+ real (kind=8), dimension(0:Lmax_v,0:mmax_v) :: ev,ew
+ real (kind=8), dimension(0:Lmax_m,0:mmax_m) :: eb,ej
+ real (kind=8), dimension(0:Lmax_t,0:mmax_t) :: et,eh
+
+ complex (kind=8), dimension(0:nmaxo,0:Lmax_v,0:mmax_v) :: vp,vt,
+ & vp1,vp2,vt1
+ complex (kind=8), dimension(0:nmaxo,0:Lmax_m,0:mmax_m) :: bp,bt,
+ & bp1,bp2,bt1
+ complex (kind=8), dimension(0:nmaxo,0:Lmax_t,0:mmax_t) :: ct,ct1
+
+C
+C SUBROUTINE STARTS HERE
+C
+
+ one = 1.0
+
+ vp = 0.0
+ vp1 = 0.0
+ vp2 = 0.0
+ vt = 0.0
+ vt1 = 0.0
+ bp = 0.0
+ bp1 = 0.0
+ bp2 = 0.0
+ bt = 0.0
+ bt1 = 0.0
+ ct = 0.0
+ ct1 = 0.0
+
+ do k = 0,nmaxo
+ do n = 0,nmax_v
+ do L = 1,Lmax_v
+ vp(k,L,0) = vp(k,L,0)+cheb(n,k)*vlm(n,L,0)
+ vp1(k,L,0)= vp1(k,L,0)+dch1(n,k)*vlm(n,L,0)
+ vp2(k,L,0)= vp2(k,L,0)+dch2(n,k)*vlm(n,L,0)
+ vt(k,L,0) = vt(k,L,0)+cheb(n,k)*wlm(n,L,0)
+ vt1(k,L,0)= vt1(k,L,0)+dch1(n,k)*wlm(n,L,0)
+ enddo
+ do m = 1,mmax_v
+ do L = m,Lmax_v
+ vp(k,L,m) = vp(k,L,m)+cheb(n,k)*vlm(n,L,m)
+ vp1(k,L,m)= vp1(k,L,m)+dch1(n,k)*vlm(n,L,m)
+ vp2(k,L,m)= vp2(k,L,m)+dch2(n,k)*vlm(n,L,m)
+ vt(k,L,m) = vt(k,L,m)+cheb(n,k)*wlm(n,L,m)
+ vt1(k,L,m)= vt1(k,L,m)+dch1(n,k)*wlm(n,L,m)
+ enddo
+ enddo
+ enddo
+ enddo
+
+ do i = 0,nmaxo
+ c1 = 1.0/rr(i)
+ k1 = nmbic+2*i+1
+ k2 = 2*i+1
+ do L = 1,Lmax_m
+ bp(i,L,0) = cob(k1,L,0)
+ bp1(i,L,0)= cob(k1+1,L,0)
+ bt(i,L,0) = coj(k1,L,0)
+ bt1(i,L,0)= coj(k1+1,L,0)
+ enddo
+ do m = 1,mmax_m
+ do L = m,Lmax_m
+ bp(i,L,m) = cob(k1,L,m)
+ bp1(i,L,m)= cob(k1+1,L,m)
+ bt(i,L,m) = coj(k1,L,m)
+ bt1(i,L,m)= coj(k1+1,L,m)
+ enddo
+ enddo
+ do m = 0,mmax_t
+ do L = m,Lmax_t
+ ct(i,L,m) = cot(k2,L,m)
+ ct1(i,L,m)= cot(k2+1,L,m)-c1*cot(k2,L,m)
+ enddo
+ enddo
+ enddo
+
+ k1 = nmaxo-1
+ k2 = nmaxo
+
+ do m = 0,mmax_m
+ do L = m,Lmax_m
+ do k = 2,nmaxo-2
+ bp2(k,L,m) = dr1(k,1)*bp1(k-2,L,m)+dr1(k,2)*
+ & bp1(k-1,L,m)+dr1(k,4)*bp1(k+1,L,m)
+ & +dr1(k,5)*bp1(k+2,L,m)
+ enddo
+ bp2(0,L,m) = dr1(0,1)*bp1(0,L,m)+dr1(0,2)*bp1(1,L,m)
+ & +dr1(0,3)*bp1(2,L,m)+dr1(0,4)*bp1(3,L,m)
+ & +dr1(0,5)*bp1(4,L,m)
+ bp2(1,L,m) = dr1(1,1)*bp1(0,L,m)+dr1(1,2)*bp1(1,L,m)
+ & +dr1(1,3)*bp1(2,L,m)+dr1(1,4)*bp1(3,L,m)
+ & +dr1(1,5)*bp1(4,L,m)
+ bp2(k1,L,m)= dr1(k1,1)*bp1(k1-3,L,m)+dr1(k1,2)*
+ & bp1(k1-2,L,m)+dr1(k1,3)*bp1(k1-1,L,m)
+ & +dr1(k1,4)*bp1(k1,L,m)+dr1(k1,5)*
+ & bp1(k1+1,L,m)
+ bp2(k2,L,m)= dr1(k2,1)*bp1(k2-4,L,m)+dr1(k2,2)*
+ & bp1(k2-3,L,m)+dr1(k2,3)*bp1(k2-2,L,m)
+ & +dr1(k2,4)*bp1(k2-1,L,m)+dr1(k2,5)*
+ & bp1(k2,L,m)
+ enddo
+ enddo
+
+
+c Obtaining the L^2-norm of the fields
+
+
+ d5 = -pi/nmaxo
+ vol = 4.0*pi*(1.0-rio*rio*rio)/3.0
+
+ ev = 0.0
+ ew = 0.0
+ eb = 0.0
+ ej = 0.0
+ et = 0.0
+ eh = 0.0
+
+ do m = 0,mmax_v
+ do L = m,Lmax_v
+
+ c1= LL(L)/rr(0)**2
+ c2= LL(L)/rr(nmaxo)**2
+ c3= LL(L)/rr(1)**2
+ c4= LL(L)/rr(nmaxo-1)**2
+ d1= LL(L)/rr(2)**2
+ d2= LL(L)/rr(nmaxo-2)**2
+ d3= LL(L)/rr(3)**2
+ d4= LL(L)/rr(nmaxo-3)**2
+
+ ev(L,m) = ev(L,m)+17.0*(gg(0)*(abs(vt(0,L,m))**2+
+ & abs(vp1(0,L,m))**2+c1*abs(vp(0,L,m))**2)+gg(nmaxo)
+ & *(abs(vt(nmaxo,L,m))**2+abs(vp1(nmaxo,L,m))**2+c2*
+ & abs(vp(nmaxo,L,m))**2))/48.0
+ ew(L,m) = ew(L,m)+17.0*(gg(0)*(abs(vt1(0,L,m))**2+abs
+ & (c1*vp(0,L,m)-vp2(0,L,m))**2+c1*abs(vt(0,L,m))**2)
+ & +gg(nmaxo)*(abs(vt1(nmaxo,L,m))**2+abs(c2*
+ & vp(nmaxo,L,m)-vp2(nmaxo,L,m))**2+c2*
+ & abs(vt(nmaxo,L,m))**2))/48.0
+
+ ev(L,m) = ev(L,m)+59.0*(gg(1)*(abs(vt(1,L,m))**2+
+ & abs(vp1(1,L,m))**2+c3*abs(vp(1,L,m))**2)+gg(nmaxo-1)
+ & *(abs(vt(nmaxo-1,L,m))**2+abs(vp1(nmaxo-1,L,m))**2+
+ & c4*abs(vp(nmaxo-1,L,m))**2))/48.0
+ ew(L,m) = ew(L,m)+59.0*(gg(1)*(abs(vt1(1,L,m))**2+
+ & abs(c3*vp(1,L,m)-vp2(1,L,m))**2+c3*abs(vt(1,L,m))**2)
+ & +gg(nmaxo-1)*(abs(vt1(nmaxo-1,L,m))**2+abs(c4*
+ & vp(nmaxo-1,L,m)-vp2(nmaxo-1,L,m))**2+c4*
+ & abs(vt(nmaxo-1,L,m))**2))/48.0
+
+ ev(L,m) = ev(L,m)+43.0*(gg(2)*(abs(vt(2,L,m))**2+
+ & abs(vp1(2,L,m))**2+d1*abs(vp(2,L,m))**2)+gg(nmaxo-2)
+ & *(abs(vt(nmaxo-2,L,m))**2+abs(vp1(nmaxo-2,L,m))**2+
+ & d2*abs(vp(nmaxo-2,L,m))**2))/48.0
+ ew(L,m) = ew(L,m)+43.0*(gg(2)*(abs(vt1(2,L,m))**2+
+ & abs(d1*vp(2,L,m)-vp2(2,L,m))**2+d1*abs(vt(2,L,m))**2)
+ & +gg(nmaxo-2)*(abs(vt1(nmaxo-2,L,m))**2+abs(d2*
+ & vp(nmaxo-2,L,m)-vp2(nmaxo-2,L,m))**2+d2*
+ & abs(vt(nmaxo-2,L,m))**2))/48.0
+
+ ev(L,m) = ev(L,m)+49.0*(gg(3)*(abs(vt(3,L,m))**2+
+ & abs(vp1(3,L,m))**2+d3*abs(vp(3,L,m))**2)+gg(nmaxo-3)
+ & *(abs(vt(nmaxo-3,L,m))**2+abs(vp1(nmaxo-3,L,m))**2+
+ & d4*abs(vp(nmaxo-3,L,m))**2))/48.0
+ ew(L,m) = ew(L,m)+49.0*(gg(3)*(abs(vt1(3,L,m))**2+
+ & abs(d3*vp(3,L,m)-vp2(3,L,m))**2+d3*abs(vt(3,L,m))**2)
+ & +gg(nmaxo-3)*(abs(vt1(nmaxo-3,L,m))**2+abs(d4*
+ & vp(nmaxo-3,L,m)-vp2(nmaxo-3,L,m))**2+d4*
+ & abs(vt(nmaxo-3,L,m))**2))/48.0
+
+ do i = 4,nmaxo-4
+ c1 = LL(L)/rr(i)**2
+ ev(L,m)= ev(L,m)+gg(i)*(abs(vt(i,L,m))**2+
+ & abs(vp1(i,L,m))**2+c1*abs(vp(i,L,m))**2)
+ ew(L,m)= ew(L,m)+gg(i)*(abs(vt1(i,L,m))**2+
+ & abs(c1*vp(i,L,m)-vp2(i,L,m))**2+c1*
+ & abs(vt(i,L,m))**2)
+ enddo
+
+ enddo
+ enddo
+
+ do m = 0,mmax_m
+ do L = m,Lmax_m
+
+ c1= LL(L)/rr(0)**2
+ c2= LL(L)/rr(nmaxo)**2
+ c3= LL(L)/rr(1)**2
+ c4= LL(L)/rr(nmaxo-1)**2
+ d1= LL(L)/rr(2)**2
+ d2= LL(L)/rr(nmaxo-2)**2
+ d3= LL(L)/rr(3)**2
+ d4= LL(L)/rr(nmaxo-3)**2
+
+ eb(L,m) = eb(L,m)+17.0*(gg(0)*(abs(bt(0,L,m))**2+
+ & abs(bp1(0,L,m))**2+c1*abs(bp(0,L,m))**2)+gg(nmaxo)
+ & *(abs(bt(nmaxo,L,m))**2+abs(bp1(nmaxo,L,m))**2+c2*
+ & abs(bp(nmaxo,L,m))**2))/48.0
+ ej(L,m) = ej(L,m)+17.0*(gg(0)*(abs(bt1(0,L,m))**2+abs
+ & (c1*bp(0,L,m)-bp2(0,L,m))**2+c1*abs(bt(0,L,m))**2)
+ & +gg(nmaxo)*(abs(bt1(nmaxo,L,m))**2+abs(c2*
+ & bp(nmaxo,L,m)-bp2(nmaxo,L,m))**2+c2*
+ & abs(bt(nmaxo,L,m))**2))/48.0
+
+ eb(L,m) = eb(L,m)+59.0*(gg(1)*(abs(bt(1,L,m))**2+
+ & abs(bp1(1,L,m))**2+c3*abs(bp(1,L,m))**2)+gg(nmaxo-1)
+ & *(abs(bt(nmaxo-1,L,m))**2+abs(bp1(nmaxo-1,L,m))**2+
+ & c4*abs(bp(nmaxo-1,L,m))**2))/48.0
+ ej(L,m) = ej(L,m)+59.0*(gg(1)*(abs(bt1(1,L,m))**2+
+ & abs(c3*bp(1,L,m)-bp2(1,L,m))**2+c3*abs(bt(1,L,m))**2)
+ & +gg(nmaxo-1)*(abs(bt1(nmaxo-1,L,m))**2+abs(c4*
+ & bp(nmaxo-1,L,m)-bp2(nmaxo-1,L,m))**2+c4*
+ & abs(bt(nmaxo-1,L,m))**2))/48.0
+
+ eb(L,m) = eb(L,m)+43.0*(gg(2)*(abs(bt(2,L,m))**2+
+ & abs(bp1(2,L,m))**2+d1*abs(bp(2,L,m))**2)+gg(nmaxo-2)
+ & *(abs(bt(nmaxo-2,L,m))**2+abs(bp1(nmaxo-2,L,m))**2+
+ & d2*abs(bp(nmaxo-2,L,m))**2))/48.0
+ ej(L,m) = ej(L,m)+43.0*(gg(2)*(abs(bt1(2,L,m))**2+
+ & abs(d1*bp(2,L,m)-bp2(2,L,m))**2+d1*abs(bt(2,L,m))**2)
+ & +gg(nmaxo-2)*(abs(bt1(nmaxo-2,L,m))**2+abs(d2*
+ & bp(nmaxo-2,L,m)-bp2(nmaxo-2,L,m))**2+d2*
+ & abs(bt(nmaxo-2,L,m))**2))/48.0
+
+ eb(L,m) = eb(L,m)+49*(gg(3)*(abs(bt(3,L,m))**2+
+ & abs(bp1(3,L,m))**2+d3*abs(bp(3,L,m))**2)+gg(nmaxo-3)
+ & *(abs(bt(nmaxo-3,L,m))**2+abs(bp1(nmaxo-3,L,m))**2+
+ & d4*abs(bp(nmaxo-3,L,m))**2))/48.0
+ ej(L,m) = ej(L,m)+49.0*(gg(3)*(abs(bt1(3,L,m))**2+
+ & abs(d3*bp(3,L,m)-bp2(3,L,m))**2+d3*abs(bt(3,L,m))**2)
+ & +gg(nmaxo-3)*(abs(bt1(nmaxo-3,L,m))**2+abs(d4*
+ & bp(nmaxo-3,L,m)-bp2(nmaxo-3,L,m))**2+d4*
+ & abs(bt(nmaxo-3,L,m))**2))/48.0
+
+ do i = 4,nmaxo-4
+ c1 = LL(L)/rr(i)**2
+ eb(L,m)= eb(L,m)+gg(i)*(abs(bt(i,L,m))**2+
+ & abs(bp1(i,L,m))**2+c1*abs(bp(i,L,m))**2)
+ ej(L,m)= ej(L,m)+gg(i)*(abs(bt1(i,L,m))**2+
+ & abs(c1*bp(i,L,m)-bp2(i,L,m))**2+c1*
+ & abs(bt(i,L,m))**2)
+ et(L,m)= et(L,m)+gg(i)*abs(ct(i,L,m))**2
+ eh(L,m)= eh(L,m)+gg(i)*(abs(ct1(i,L,m))**2+
+ & c1*abs(ct(i,L,m))**2)
+ enddo
+
+ enddo
+ enddo
+
+ do m = 0,mmax_t
+ do L = m,Lmax_t
+
+ c1= LL(L)/rr(0)**2
+ c2= LL(L)/rr(nmaxo)**2
+ c3= LL(L)/rr(1)**2
+ c4= LL(L)/rr(nmaxo-1)**2
+ d1= LL(L)/rr(2)**2
+ d2= LL(L)/rr(nmaxo-2)**2
+ d3= LL(L)/rr(3)**2
+ d4= LL(L)/rr(nmaxo-3)**2
+
+ et(L,m) = et(L,m)+17.0*(gg(0)*abs(ct(0,L,m))**2+
+ & gg(nmaxo)*abs(ct(nmaxo,L,m))**2)/48.0
+ eh(L,m) = eh(L,m)+17.0*(gg(0)*(abs(ct1(0,L,m))**2+
+ & c1*abs(ct(0,L,m))**2)+gg(nmaxo)*(abs(ct1(nmaxo,
+ & L,m))**2+c2*abs(ct(nmaxo,L,m))**2))/48.0
+
+ et(L,m) = et(L,m)+59.0*(gg(1)*abs(ct(1,L,m))**2+
+ & gg(nmaxo-1)*abs(ct(nmaxo-1,L,m))**2)/48.0
+ eh(L,m) = eh(L,m)+59.0*(gg(1)*(abs(ct1(1,L,m))**2+
+ & c3*abs(ct(1,L,m))**2)+gg(nmaxo-1)*(abs(ct1(nmaxo-1,
+ & L,m))**2+c4*abs(ct(nmaxo-1,L,m))**2))/48.0
+
+ et(L,m) = et(L,m)+43.0*(gg(2)*abs(ct(2,L,m))**2+
+ & gg(nmaxo-2)*abs(ct(nmaxo-2,L,m))**2)/48.0
+ eh(L,m) = eh(L,m)+43.0*(gg(2)*(abs(ct1(2,L,m))**2+
+ & d1*abs(ct(2,L,m))**2)+gg(nmaxo-2)*(abs(ct1(nmaxo-2,
+ & L,m))**2+d2*abs(ct(nmaxo-2,L,m))**2))/48.0
+
+ et(L,m) = et(L,m)+49.0*(gg(3)*abs(ct(3,L,m))**2+
+ & gg(nmaxo-3)*abs(ct(nmaxo-3,L,m))**2)/48.0
+ eh(L,m) = eh(L,m)+49.0*(gg(3)*(abs(ct1(3,L,m))**2+
+ & d3*abs(ct(3,L,m))**2)+gg(nmaxo-3)*(abs(ct1(nmaxo-3,
+ & L,m))**2+d4*abs(ct(nmaxo-3,L,m))**2))/48.0
+
+ do i = 4,nmaxo-4
+ c1 = LL(L)/rr(i)**2
+ et(L,m)= et(L,m)+gg(i)*abs(ct(i,L,m))**2
+ eh(L,m)= eh(L,m)+gg(i)*(abs(ct1(i,L,m))**2+
+ & c1*abs(ct(i,L,m))**2)
+ enddo
+
+ enddo
+ enddo
+
+ c1 = d5/vol
+ do m = 0,mmax_v
+ do L = m,Lmax_v
+ c2 = LL(L)*c1
+ ev(L,m) = ev(L,m)*c2
+ ew(L,m) = ew(L,m)*c2
+ enddo
+ enddo
+ do m = 0,mmax_m
+ do L = m,Lmax_m
+ c2 = LL(L)*c1
+ eb(L,m) = eb(L,m)*c2
+ ej(L,m) = ej(L,m)*c2
+ enddo
+ enddo
+ do m = 0,mmax_t
+ do L = m,Lmax_t
+ et(L,m) = et(L,m)*c1
+ eh(L,m) = eh(L,m)*c1
+ enddo
+ enddo
+
+ L = (Lmax_v+1)*(mmax_v+1)
+ amv = dasum(L,ev(0,0),1)
+ amw = dasum(L,ew(0,0),1)
+ L = (Lmax_m+1)*(mmax_m+1)
+ amb = dasum(L,eb(0,0),1)
+ amj = dasum(L,ej(0,0),1)
+ L = (Lmax_t+1)*(mmax_t+1)
+ amt = dasum(L,et(0,0),1)
+ amh = dasum(L,eh(0,0),1)
+
+ amv = sqrt(abs(amv))
+ amw = sqrt(abs(amw))
+ amb = sqrt(abs(amb))
+ amj = sqrt(abs(amj))
+ amt = sqrt(abs(amt))
+ amh = sqrt(abs(amh))
+
+ elb = amb/amj
+ elv = amv/amw
+ elt = amt/amh
+
+ return
+ end
+
Property changes on: geodyn/3D/MoSST/trunk/miscs.f
___________________________________________________________________
Name: svn:executable
+
Added: geodyn/3D/MoSST/trunk/mod_anomaly.f
===================================================================
--- geodyn/3D/MoSST/trunk/mod_anomaly.f 2006-10-23 16:55:10 UTC (rev 5079)
+++ geodyn/3D/MoSST/trunk/mod_anomaly.f 2006-10-23 20:50:23 UTC (rev 5080)
@@ -0,0 +1,81 @@
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ MODULE mod_cmbheat
+
+!
+! This module defines the background temperature profile with a
+! given heterogeneous heat fluxes at CMB and at the ICB
+!
+! HTF_CMB: the heat flux profile at the CMB;
+! HTF_ICB: the heat flux profile at the ICB;
+! EPSHT_CMB: the amplitude of the non-axisymmetric heatflux
+! at CMB (relative to the spherically symmetric
+! heat flux);
+! EPSHT_ICB: the amplitude of the non-axisymmetric heatflux
+! at ICB (relative to the spherically symmetric
+! heat flux);
+! LHEAT_CMB: the maximum degree of the heat flux HTF_CMB;
+! LHEAT_ICB: the maximum degree of the heat flux HTF_ICB;
+!
+! T0H: the incoming heterogeneous heat flux (dT/dr) at the CMB;
+! DT0R: - d/dr of the spherically symmetric conducting
+! temperature profile;
+! DRT0H: - d/dr of the heterogeneous temperature profile;
+! DTT0H: - sin(th) d/dth of the the heterogeneous temperature profile;
+! DPT0H: - d/dph of the the heterogeneous temperature profile;
+!
+! Author: Weijia Kuang
+! Date: Feb., 2001
+! Date of Last Modified: Nov. 2003
+!
+! COPY RIGHT: THIS CODE CAN NOT BE DUPLICATED OR USED WITHOUT
+! THE PERMISSION OF THE AUTHOR.
+!
+
+ use mod_dimparam
+ use mod_sysparam
+ use mod_optparam
+
+ use mod_radgeom
+ use mod_sphgeom
+
+ implicit none
+
+ real (kind=8) dt0r(0:nmaxo)
+
+ CONTAINS
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ SUBROUTINE cmbheat_basic
+
+ implicit none
+
+ integer i
+
+c Spherically symmetric temperature profile
+
+ dt0r = 0.0
+
+ if (indxt .eq. 0) then
+ do i = 0,nmaxo
+ dt0r(i) = alpht*rr(i)/3.0+(1.0-alpht*rio/3.0)*
+ & (rio/rr(i))**2
+ enddo
+ else if (indxt .eq. 1) then
+ do i = 0,nmaxo
+ dt0r(i) = rr(i)
+ enddo
+ endif
+
+ END SUBROUTINE cmbheat_basic
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ END MODULE mod_cmbheat
+
Property changes on: geodyn/3D/MoSST/trunk/mod_anomaly.f
___________________________________________________________________
Name: svn:executable
+
Added: geodyn/3D/MoSST/trunk/mod_artdis.f
===================================================================
--- geodyn/3D/MoSST/trunk/mod_artdis.f 2006-10-23 16:55:10 UTC (rev 5079)
+++ geodyn/3D/MoSST/trunk/mod_artdis.f 2006-10-23 20:50:23 UTC (rev 5080)
@@ -0,0 +1,66 @@
+c
+c This module defines the artificial dissipation used in the modeling.
+c
+c AVISV1: the artificial viscosity parameter in meridional direction;
+c AVISV2: the artificial viscosity parameter in radial direction;
+c NAVFV1: the truncation level of the meridional artificial viscosity;
+c NAVFV2: the truncation level of the radial artificial viscosity;
+c AVISMV: the artificial viscosity vector;
+c
+c AVISB: the artificial magnetic diffusion in meridional direction;
+c NAVFB: the truncation level of the meridional diffusivity;
+c AVISMB: the artificial diffusion vector;
+c
+c AVIST: the artificial thermal conduction in meridional direction;
+c NAVFT: the truncation level of the meridional conduction;
+c AVISMT: the artificial conduction vector;
+c
+c Author: Weijia Kuang
+c Date: Jan., 2001
+c COPY RIGHT: THIS CODE CAN NOT BE DUPLICATED OR USED WITHOUT
+c THE PERMISSION OF THE AUTHOR.
+c
+
+ MODULE mod_artdis
+
+ use mod_dimparam
+
+ implicit none
+ integer navfv1,navfv2,navfb,navft
+ real (kind=8) avisv1,avisv2,avisb,avist
+ real (kind=8) avismv(0:Lmax_v,0:nmaxo)
+ real (kind=8) avismb(0:Lmax_m),avismt(0:Lmax_t)
+
+ CONTAINS
+
+c The subroutine that defines the artificial dissipation
+c vectors
+
+ subroutine artdis
+
+ implicit none
+ integer i,L
+
+ avismv = 1.0
+ avismb = 1.0
+ avismt = 1.0
+ do L = navfb,Lmax_m
+ avismb(L) = avismb(L)+avisb*(L-navfb)**2
+ enddo
+ do L = navft,Lmax_t
+ avismt(L) = avismt(L)+avist*(L-navft)**2
+ enddo
+ do i = 0,nmaxo
+ do L = navfv1,Lmax_v
+ avismv(L,i) = avismv(L,i)+avisv1*(L-navfv1)**2
+ enddo
+ enddo
+ do i = navfv2,nmaxo
+ do L = 0,Lmax_v
+ avismv(L,i) = avismv(L,i)+avisv2*(i-navfv2)**2
+ enddo
+ enddo
+
+ end subroutine artdis
+
+ END MODULE mod_artdis
Property changes on: geodyn/3D/MoSST/trunk/mod_artdis.f
___________________________________________________________________
Name: svn:executable
+
Added: geodyn/3D/MoSST/trunk/mod_dataio.f
===================================================================
--- geodyn/3D/MoSST/trunk/mod_dataio.f 2006-10-23 16:55:10 UTC (rev 5079)
+++ geodyn/3D/MoSST/trunk/mod_dataio.f 2006-10-23 20:50:23 UTC (rev 5080)
@@ -0,0 +1,527 @@
+c
+c This module defines the strings and the lengths of input/output data
+c files;
+c
+c usr_name: the user account name for storage space;
+c code_geom: the geometry notation of the model;
+c
+c disc_in: the disc name for the input data file;
+c subdir_in: the directory for the input data file;
+c version_in: the version for the input data file;
+c fileno_in: the sequence number of the input data file
+c file_in: the input data file name;
+c length_din: the string length for the input data directory name;
+c length_in: the string length for the input data file name;
+c
+c disc_out: the disc name for the output data file;
+c subdir_out: the directory for the output data file;
+c version_out: the version for the output data file;
+c fileno_out: the sequence number of the output data file;
+c file_out: the output data file name;
+c length_dout: the string length for the output data directory name;
+c length_out: the string length for the output data file name;
+c
+c disc_diag: the disc name for the diagnostic data file;
+c subdir_diag: the directory for the diagnostic data file;
+c version_diag:the version for the diagnostic file;
+c file_diag: the diagnostic file name;
+c length_ddiag:the string length for the diagnostic directory name;
+c length_diag: the string length for the diagnostic file name;
+!
+! disc_anom: the disc name for the heterogeneity data file;
+! subdir_anom: the directory for the heterogeneity data file;
+! version_anom:the version for the heterogeneity file;
+! length_anom: the string length for the file_anom;
+!
+c THE DIAGNOSTIC FILE IS BEST DEFINED IN THE SAME DIRECTORY AS
+c THE OUTPUT DATA FILES.
+c
+c Author: Weijia Kuang
+c Date: Jan., 2002
+c COPY RIGHT: THIS CODE CAN NOT BE DUPLICATED OR USED WITHOUT
+c THE PERMISSION OF THE AUTHOR.
+c
+
+ MODULE mod_dataio
+
+ use mod_dimparam
+ use mod_vfield
+ use mod_bfield
+ use mod_tfield
+ use mod_rotation
+
+ implicit none
+
+ integer fileno_in,fileno_out
+ integer length_in,length_out,length_diag,length_anom
+ integer length_din,length_dout,length_ddiag
+ character*20 disc_in,disc_out,disc_diag,disc_anom,usr_name
+ character*20 subdir_in,subdir_out,subdir_diag,subdir_anom
+ character*20 version_in,version_out,version_diag,code_geom,
+ & version_anom
+ character*100 direct_in,direct_out,direct_diag,direct_anom
+ character*200 file_in,file_out,file_diag
+
+ CONTAINS
+
+********************************************************************
+********************************************************************
+
+c The subroutine defines the directory path for the data I/O
+
+ SUBROUTINE directname
+
+ implicit none
+ integer i1,i2,i3,i4,j,k
+ character*50 file_indx
+
+ length_din = 0
+ length_dout = 0
+ length_ddiag = 0
+ length_anom = 0
+
+c (1) Define the input data directory
+
+ i1 = len_trim(disc_in)
+ i2 = len_trim(usr_name)
+
+ if (i1 .gt. 0) then
+ direct_in(1:1) = "/"
+ direct_in(2:i1+1) = disc_in(1:i1)
+ k = i1+1
+ if (i2 .gt. 0) then
+ direct_in(k+1:k+1) = "/"
+ direct_in(k+2:k+i2+1) = usr_name(1:i2)
+ k = k+i2+1
+ endif
+ else
+ direct_in(1:5) = "$HOME"
+ k = 5
+ endif
+
+ i1 = len_trim(subdir_in)
+ i2 = len_trim(version_in)
+
+ if (i1 .gt. 0) then
+ direct_in(k+1:k+1) = "/"
+ direct_in(k+2:k+i1+1) = subdir_in(1:i1)
+ k = k+i1+1
+ endif
+ if (i2 .gt. 0) then
+ direct_in(k+1:k+1) = "/"
+ direct_in(k+2:k+i2+1) = version_in(1:i2)
+ k = k+i2+1
+ endif
+
+ direct_in(k+1:k+1) = "/"
+
+ length_din = k+1
+
+c (2) Define the output data file directory
+
+ i1 = len_trim(disc_out)
+ i2 = len_trim(usr_name)
+
+ if (i1 .gt. 0) then
+ direct_out(1:1) = "/"
+ direct_out(2:i1+1) = disc_out(1:i1)
+ k = i1+1
+ if (i2 .gt. 0) then
+ direct_out(k+1:k+1) = "/"
+ direct_out(k+2:k+i2+1) = usr_name(1:i2)
+ k = k+i2+1
+ endif
+ else
+ direct_out(1:5) = "$HOME"
+ k = 5
+ endif
+
+ i1 = len_trim(subdir_out)
+ i2 = len_trim(version_out)
+
+ if (i1 .gt. 0) then
+ direct_out(k+1:k+1) = "/"
+ direct_out(k+2:k+i1+1) = subdir_out(1:i1)
+ k = k+i1+1
+ endif
+ if (i2 .gt. 0) then
+ direct_out(k+1:k+1) = "/"
+ direct_out(k+2:k+i2+1) = version_out(1:i2)
+ k = k+i2+1
+ endif
+
+ direct_out(k+1:k+1) = "/"
+
+ length_dout = k+1
+
+c (3) Define the diagnostic data directory
+
+ i1 = len_trim(disc_diag)
+ i2 = len_trim(usr_name)
+
+ if (i1 .gt. 0) then
+ direct_diag(1:1) = "/"
+ direct_diag(2:i1+1) = disc_diag(1:i1)
+ k = i1+1
+ if (i2 .gt. 0) then
+ direct_diag(k+1:k+1) = "/"
+ direct_diag(k+2:k+i2+1) = usr_name(1:i2)
+ k = k+i2+1
+ endif
+ else
+ direct_diag(1:5) = "$HOME"
+ k = 5
+ endif
+
+ i1 = len_trim(subdir_diag)
+ i2 = len_trim(version_diag)
+
+ if (i1 .gt. 0) then
+ direct_diag(k+1:k+1) = "/"
+ direct_diag(k+2:k+i1+1) = subdir_diag(1:i1)
+ k = k+i1+1
+ endif
+ if (i2 .gt. 0) then
+ direct_diag(k+1:k+1) = "/"
+ direct_diag(k+2:k+i2+1) = version_diag(1:i2)
+ k = k+i2+1
+ endif
+
+ direct_diag(k+1:k+1) = "/"
+
+ length_ddiag = k+1
+
+c (4) Define the heterogeneity data directory
+
+ i1 = len_trim(disc_anom)
+ i2 = len_trim(usr_name)
+
+ if (i1 .gt. 0) then
+ direct_anom(1:1) = "/"
+ direct_anom(2:i1+1) = disc_anom(1:i1)
+ k = i1+1
+ if (i2 .gt. 0) then
+ direct_anom(k+1:k+1) = "/"
+ direct_anom(k+2:k+i2+1) = usr_name(1:i2)
+ k = k+i2+1
+ endif
+ else
+ direct_anom(1:5) = "$HOME"
+ k = 5
+ endif
+
+ i1 = len_trim(subdir_anom)
+ i2 = len_trim(version_anom)
+
+ if (i1 .gt. 0) then
+ direct_anom(k+1:k+1) = "/"
+ direct_anom(k+2:k+i1+1) = subdir_anom(1:i1)
+ k = k+i1+1
+ endif
+ if (i2 .gt. 0) then
+ direct_anom(k+1:k+1) = "/"
+ direct_anom(k+2:k+i2+1) = version_anom(1:i2)
+ k = k+i2+1
+ endif
+
+ direct_anom(k+1:k+1) = "/"
+
+ length_anom = k+1
+
+ END SUBROUTINE directname
+
+********************************************************************
+********************************************************************
+
+c The subroutine defines the input data file name
+
+ SUBROUTINE infilename
+
+ implicit none
+ integer i1,i2,i3,i4,j,k
+ character*50 file_indx, file_tmp
+
+c (1) Define the input data directory
+
+ k = length_din
+ if (k .eq. 0) then
+ call directname
+ k = length_din
+ endif
+
+c (2) Define the input data file name
+
+ file_in(1:k) = direct_in(1:k)
+
+ i1= len_trim(code_geom)
+ i2= len_trim(version_in)
+
+ if (i1 .gt. 0) then
+ file_in(k+1:k+i1) = code_geom(1:i1)
+ file_in(k+i1+1:k+i1+1) = "."
+ k = k+i1+1
+ endif
+ if (i2 .gt. 0) then
+ file_in(k+1:k+i2) = version_in(1:i2)
+ file_in(k+i2+1:k+i2+1) = "."
+ k = k+i2+1
+ endif
+
+ write(file_tmp, *) fileno_in
+ file_indx = adjustl(file_tmp)
+ i3 = len_trim(file_indx)
+ file_in(k+1:k+i3) = file_indx(1:i3)
+
+ length_in = k+i3
+
+ END SUBROUTINE infilename
+
+********************************************************************
+********************************************************************
+
+c The subroutine defines the output data file name
+
+ SUBROUTINE outfilename
+
+ implicit none
+ integer i1,i2,i3,i4,j,k
+ character*50 file_indx,file_tmp
+
+c (1) Define the output data directory
+
+ k = length_dout
+ if (k. eq. 0) then
+ call directname
+ k = length_dout
+ endif
+
+c (2) Define the output data file name
+
+ file_out(1:k) = direct_out(1:k)
+
+ i1= len_trim(code_geom)
+ i2= len_trim(version_out)
+
+ if (i1 .gt. 0) then
+ file_out(k+1:k+i1) = code_geom(1:i1)
+ file_out(k+i1+1:k+i1+1) = "."
+ k = k+i1+1
+ endif
+ if (i2 .gt. 0) then
+ file_out(k+1:k+i2) = version_out(1:i2)
+ file_out(k+i2+1:k+i2+1) = "."
+ k = k+i2+1
+ endif
+
+ write(file_tmp, *) fileno_out
+ file_indx = adjustl(file_tmp)
+ i3 = len_trim(file_indx)
+ file_out(k+1:k+i3) = file_indx(1:i3)
+
+ length_out = k+i3
+
+ END SUBROUTINE outfilename
+
+********************************************************************
+********************************************************************
+
+c The subroutine defines the diagnostic file name
+
+ SUBROUTINE diagfilename
+
+ implicit none
+ integer i1,k
+
+c (1) Define the diagnostic data directory
+
+ k = length_ddiag
+ if (k .eq. 0) then
+ call directname
+ k = length_ddiag
+ endif
+
+c (2) Define the diagnostic file name
+
+ file_diag(1:k) = direct_diag(1:k)
+
+ i1= len_trim(version_diag)
+
+ if (i1 .gt. 0) then
+ file_diag(k+1:k+i1) = version_diag(1:i1)
+ k = k+i1
+ endif
+
+ file_diag(k+1:k+1) = "_"
+ length_diag = k+1
+! file_diag(k+2:k+9) = "diag_out"
+! length_diag = k+9
+
+ END SUBROUTINE diagfilename
+
+********************************************************************
+********************************************************************
+
+c The subroutine defines dynamo state input
+
+ SUBROUTINE data_in
+
+ implicit none
+ integer L,m,k
+
+c (1) Define the input file name
+
+ call infilename
+
+c (2) Open the path
+
+ open(unit=22,file=file_in(1:length_in),form="unformatted",
+ & action="read")
+
+c (3) Read in the dynamo state
+
+ coua = 0.0
+ coub = 0.0
+ cova = 0.0
+ covb = 0.0
+ cob = 0.0
+ coj = 0.0
+ cot = 0.0
+ vlm = 0.0
+ wlm = 0.0
+
+ read(22) omgih,omgiz,omgmh,omgmz
+ read(22) (coua(k),k=1,nmx2)
+ read(22) (coub(k),k=1,nmx2)
+ read(22) (cova(k),k=1,nmx1)
+ read(22) (covb(k),k=1,nmx1)
+ read(22) ((cob(k,L,0),k=1,nmb),L=1,Lmax_m)
+ read(22) (((cob(k,L,m),k=1,nmb),L=m,Lmax_m),m=1,mmax_m)
+ read(22) ((coj(k,L,0),k=1,nmb),L=1,Lmax_m)
+ read(22) (((coj(k,L,m),k=1,nmb),L=m,Lmax_m),m=1,mmax_m)
+ read(22) (((cot(k,L,m),k=1,nmx3),L=m,Lmax_t),m=0,mmax_t)
+
+ close(22)
+
+ call group
+
+ END SUBROUTINE data_in
+
+********************************************************************
+********************************************************************
+
+c The subroutine defines dynamo state input
+
+ SUBROUTINE data_out
+
+ implicit none
+ integer L,m,k
+
+c (1) Define the output file name
+
+ call outfilename
+
+c (2) Open the path
+
+ open(unit=22,file=file_out(1:length_out),form="unformatted")
+
+c (3) Write out the dynamo state
+
+ write(22) omgih,omgiz,omgmh,omgmz
+ write(22) (coua(k),k=1,nmx2)
+ write(22) (coub(k),k=1,nmx2)
+ write(22) (cova(k),k=1,nmx1)
+ write(22) (covb(k),k=1,nmx1)
+ write(22) ((cob(k,L,0),k=1,nmb),L=1,Lmax_m)
+ write(22) (((cob(k,L,m),k=1,nmb),L=m,Lmax_m),m=1,mmax_m)
+ write(22) ((coj(k,L,0),k=1,nmb),L=1,Lmax_m)
+ write(22) (((coj(k,L,m),k=1,nmb),L=m,Lmax_m),m=1,mmax_m)
+ write(22) (((cot(k,L,m),k=1,nmx3),L=m,Lmax_t),m=0,mmax_t)
+
+ close(22)
+
+ END SUBROUTINE data_out
+
+********************************************************************
+********************************************************************
+
+c The subroutine defines dynamo state input
+
+ SUBROUTINE data_in1
+
+ implicit none
+ integer L,m,k
+
+c (1) Define the input file name
+
+ call infilename
+
+c (2) Open the path
+
+ open(unit=22,file=file_in(1:length_in),form="unformatted",
+ & action="read")
+
+c (3) Read in the dynamo state
+
+ cob = 0.0
+ coj = 0.0
+ cot = 0.0
+ vlm = 0.0
+ wlm = 0.0
+
+ read(22) omgih,omgiz,omgmh,omgmz
+ read(22) ((vlm(k,L,0), k=0,nmax_v),L=1,Lmax_v)
+ read(22) (((vlm(k,L,m), k=0,nmax_v),L=m,Lmax_v),m=1,mmax_v)
+ read(22) ((wlm(k,L,0), k=0,nmax_v),L=1,Lmax_v)
+ read(22) (((wlm(k,L,m), k=0,nmax_v),L=m,Lmax_v),m=1,mmax_v)
+ read(22) ((cob(k,L,0),k=1,nmb),L=1,Lmax_m)
+ read(22) (((cob(k,L,m),k=1,nmb),L=m,Lmax_m),m=1,mmax_m)
+ read(22) ((coj(k,L,0),k=1,nmb),L=1,Lmax_m)
+ read(22) (((coj(k,L,m),k=1,nmb),L=m,Lmax_m),m=1,mmax_m)
+ read(22) (((cot(k,L,m),k=1,nmx3),L=m,Lmax_t),m=0,mmax_t)
+
+ close(22)
+
+ call regroup
+
+ END SUBROUTINE data_in1
+
+********************************************************************
+********************************************************************
+
+c The subroutine defines dynamo state input
+
+ SUBROUTINE data_out1
+
+ implicit none
+ integer L,m,k
+
+c (1) Define the output file name
+
+ call outfilename
+
+c (2) Open the path
+
+ open(unit=22,file=file_out(1:length_out),form="unformatted")
+
+c (3) Write out the dynamo state
+
+ write(22) omgih,omgiz,omgmh,omgmz
+ write(22) ((vlm(k,L,0),k=0,nmax_v),L=1,Lmax_v)
+ write(22) (((vlm(k,L,m),k=0,nmax_v),L=m,Lmax_v),m=1,mmax_v)
+ write(22) ((wlm(k,L,0),k=0,nmax_v),L=1,Lmax_v)
+ write(22) (((wlm(k,L,m),k=0,nmax_v),L=m,Lmax_v),m=1,mmax_v)
+ write(22) ((cob(k,L,0),k=1,nmb),L=1,Lmax_m)
+ write(22) (((cob(k,L,m),k=1,nmb),L=m,Lmax_m),m=1,mmax_m)
+ write(22) ((coj(k,L,0),k=1,nmb),L=1,Lmax_m)
+ write(22) (((coj(k,L,m),k=1,nmb),L=m,Lmax_m),m=1,mmax_m)
+ write(22) (((cot(k,L,m),k=1,nmx3),L=m,Lmax_t),m=0,mmax_t)
+
+ close(22)
+
+ END SUBROUTINE data_out1
+
+********************************************************************
+********************************************************************
+
+ END MODULE mod_dataio
+
Property changes on: geodyn/3D/MoSST/trunk/mod_dataio.f
___________________________________________________________________
Name: svn:executable
+
Added: geodyn/3D/MoSST/trunk/mod_fields.f
===================================================================
--- geodyn/3D/MoSST/trunk/mod_fields.f 2006-10-23 16:55:10 UTC (rev 5079)
+++ geodyn/3D/MoSST/trunk/mod_fields.f 2006-10-23 20:50:23 UTC (rev 5080)
@@ -0,0 +1,252 @@
+!
+! This group of the modules defines the solution fields of the model.
+!
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+c
+c This module defines the velocity field vectors and the conversions
+c between two different representations of the velocity field.
+c
+c (COUA,COUB): the velocity vectors for (m <= miner);
+c (COVA,COVB): asymmmatric velocity vectors for (m > miner);
+c VLM: poloidal velocity expansion coefficients;
+c WLM: toroidal velocity expansion coefficients;
+c
+c Two symmetry groups of velocity perturbations:
+c
+c Group I:
+c {v^L, w^[L+1]}, {L = m,m+2,....};
+c Group II:
+c {w^[L-1], v^L}, {L = m+1,m+3,...};
+c
+c Author: Weijia Kuang
+c Date: Mar., 2002
+c COPY RIGHT: THIS CODE CAN NOT BE DUPLICATED OR USED WITHOUT
+c THE PERMISSION OF THE AUTHOR.
+c
+
+ MODULE mod_vfield
+
+ use mod_dimparam
+ use mod_parity
+
+ implicit none
+
+ complex (kind=8) coua(nmx2),coub(nmx2)
+ complex (kind=8) cova(nmx1),covb(nmx1)
+ complex (kind=8), dimension(0:nmax_v,Lmax_v,0:mmax_v) :: vlm,
+ & wlm
+
+ CONTAINS
+
+
+c Two subroutines for conversions between (vlm,wlm) and
+c (coua,coub,cova,covb)
+
+***********************************************************************
+***********************************************************************
+
+ SUBROUTINE group
+
+ implicit none
+ integer m,L1,Lcca,Lccb,Lcc1,La,Lb
+
+ vlm = 0.0
+ wlm = 0.0
+
+ do L1 = 1,lsym_v(0)
+ La = 2*L1-1
+ Lb = 2*L1
+ Lcca = 2*(L1-1)*nmxo1+1
+ Lccb = (2*L1-1)*nmxo1+1
+ vlm(:,La,0) = coua(Lcca:Lcca+nmax_v)
+ vlm(:,Lb,0) = coub(Lccb:Lccb+nmax_v)
+ wlm(:,La,0) = coub(Lcca:Lcca+nmax_v)
+ wlm(:,Lb,0) = coua(Lccb:Lccb+nmax_v)
+ enddo
+
+ do m = 1,miner
+ Lcc1 = kdm(m-1)
+ do L1= 0,lsym_v(m)
+ La= m+2*L1
+ Lb= m+2*L1+1
+ Lcca= Lcc1+2*L1*nmxo1+1
+ Lccb= Lcc1+(2*L1+1)*nmxo1+1
+ vlm(:,La,m) = coua(Lcca:Lcca+nmax_v)
+ vlm(:,Lb,m) = coub(Lccb:Lccb+nmax_v)
+ wlm(:,La,m) = coub(Lcca:Lcca+nmax_v)
+ wlm(:,Lb,m) = coua(Lccb:Lccb+nmax_v)
+ enddo
+ enddo
+
+ do m = miner+1,mmax_v
+ Lcc1 = kdm(m-1)-kdm(miner)
+ do L1= 0,lsym_v(m)
+ La= m+2*L1
+ Lb= m+2*L1+1
+ Lcca= Lcc1+2*L1*nmxo1+1
+ Lccb= Lcc1+(2*L1+1)*nmxo1+1
+ vlm(:,La,m) = covb(Lcca:Lcca+nmax_v)
+ vlm(:,Lb,m) = cova(Lccb:Lccb+nmax_v)
+ wlm(:,La,m) = cova(Lcca:Lcca+nmax_v)
+ wlm(:,Lb,m) = covb(Lccb:Lccb+nmax_v)
+ enddo
+ enddo
+
+
+ END SUBROUTINE group
+
+***********************************************************************
+***********************************************************************
+
+ SUBROUTINE regroup
+
+ implicit none
+ integer m,L1,Lcca,Lccb,Lcc1,La,Lb
+
+ coua = 0.0
+ coub = 0.0
+ cova = 0.0
+ covb = 0.0
+
+ do L1 = 1,lsym_v(0)
+ La = 2*L1-1
+ Lb = 2*L1
+ Lcca = 2*(L1-1)*nmxo1+1
+ Lccb = (2*L1-1)*nmxo1+1
+ coua(Lcca:Lcca+nmax_v) = vlm(:,La,0)
+ coua(Lccb:Lccb+nmax_v) = wlm(:,Lb,0)
+ coub(Lcca:Lcca+nmax_v) = wlm(:,La,0)
+ coub(Lccb:Lccb+nmax_v) = vlm(:,Lb,0)
+ enddo
+
+ do m = 1,miner
+ Lcc1 = kdm(m-1)
+ do L1= 0,lsym_v(m)
+ La= m+2*L1
+ Lb= m+2*L1+1
+ Lcca= Lcc1+2*L1*nmxo1+1
+ Lccb= Lcc1+(2*L1+1)*nmxo1+1
+ coua(Lcca:Lcca+nmax_v) = vlm(:,La,m)
+ coua(Lccb:Lccb+nmax_v) = wlm(:,Lb,m)
+ coub(Lcca:Lcca+nmax_v) = wlm(:,La,m)
+ coub(Lccb:Lccb+nmax_v) = vlm(:,Lb,m)
+ enddo
+ enddo
+
+ do m = miner+1,mmax_v
+ Lcc1 = kdm(m-1)-kdm(miner)
+ do L1= 0,lsym_v(m)
+ La= m+2*L1
+ Lb= m+2*L1+1
+ Lcca= Lcc1+2*L1*nmxo1+1
+ Lccb= Lcc1+(2*L1+1)*nmxo1+1
+ cova(Lcca:Lcca+nmax_v) = wlm(:,La,m)
+ cova(Lccb:Lccb+nmax_v) = vlm(:,Lb,m)
+ covb(Lcca:Lcca+nmax_v) = vlm(:,La,m)
+ covb(Lccb:Lccb+nmax_v) = wlm(:,Lb,m)
+ enddo
+ enddo
+
+
+ END SUBROUTINE regroup
+
+********************************************************************
+********************************************************************
+
+ END MODULE mod_vfield
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+c
+c This module defines the magnetic field vectors
+c
+c COB: poloidal field expansion coefficients;
+c COJ: toroidal field expansion coefficients; *
+c
+c Author: Weijia Kuang
+c Date: Feb., 2001
+c COPY RIGHT: THIS CODE CAN NOT BE DUPLICATED OR USED WITHOUT
+c THE PERMISSION OF THE AUTHOR.
+c
+
+ MODULE mod_bfield
+
+ use mod_dimparam
+
+ implicit none
+
+ complex (kind=8), dimension(nmx6,Lmax_m,0:mmax_m) :: cob,coj
+
+ END MODULE mod_bfield
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+c
+c This module defines the temperature field vector
+c
+c COT: temperature perturbation;
+c
+c Author: Weijia Kuang
+c Date: Feb., 2001
+c COPY RIGHT: THIS CODE CAN NOT BE DUPLICATED OR USED WITHOUT
+c THE PERMISSION OF THE AUTHOR.
+c
+
+ MODULE mod_tfield
+
+ use mod_dimparam
+
+ implicit none
+
+ complex (kind=8) cot(nmx3,0:Lmax_t,0:mmax_t)
+
+ END MODULE mod_tfield
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+c
+c This module defines the solid body rotation of the inner core
+c and the solid mantle
+c
+c (OMGIH,OMGIZ): the rotation rate of the inner core;
+c (OMGMH,OMGMZ): the rotation rate of the mantle;
+c
+c OMGH = OMGX + i OMGY;
+c
+c Author: Weijia Kuang
+c Date: Feb., 2001
+c COPY RIGHT: THIS CODE CAN NOT BE DUPLICATED OR USED WITHOUT
+c THE PERMISSION OF THE AUTHOR.
+c
+
+ MODULE mod_rotation
+
+ implicit none
+
+ real (kind=8) omgiz,omgmz
+ complex (kind=8) omgih,omgmh
+
+ END MODULE mod_rotation
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
Property changes on: geodyn/3D/MoSST/trunk/mod_fields.f
___________________________________________________________________
Name: svn:executable
+
Added: geodyn/3D/MoSST/trunk/mod_matrices.f
===================================================================
--- geodyn/3D/MoSST/trunk/mod_matrices.f 2006-10-23 16:55:10 UTC (rev 5079)
+++ geodyn/3D/MoSST/trunk/mod_matrices.f 2006-10-23 20:50:23 UTC (rev 5080)
@@ -0,0 +1,1860 @@
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+c
+c This module defines the matrices for the momentum equation
+c that solves the velocity field
+c
+c (CUA1,CUA2): the matrices for the momentum
+c equation with (m <= miner);
+c MLU: the # of diagonals below the main diagonal;
+c MUU: the # of diagonals above the main diagonal;
+c LU1 = 2*MLU+MUU+1;
+c LU2 = MLU+MUU+1;
+c NMX2: the leading dimension of (CUA, CUB);
+c NDU: the order of (CUA,CUB);
+c IPVTUA: the pivoting index for CUA1;
+c IPVTUB: the pivoting index for CUB1;
+c
+c (CVA, CVB): the matrices for the momentum equation with
+c (m >= miner+1);
+c MLV: the # of diagonals below the main diagonal;
+c MUV: the # of diagonals below the main diagonal;
+c LV = 2*MLV+MUV+1;
+c NMX1: the leading dimension of (CVA, CVB);
+c NDV: the order of (CVA,CVB);
+c IPVTVA: the pivoting index for CVA;
+c IPVTVB: the pivoting index for CVB;
+c
+c Author: Weijia Kuang
+c Date: Mar., 2002
+c COPY RIGHT: THIS CODE CAN NOT BE DUPLICATED OR USED WITHOUT
+c THE PERMISSION OF THE AUTHOR.
+c
+
+ MODULE mod_vmatrix
+
+ use mod_dimparam
+ use mod_sysparam
+ use mod_numparam
+ use mod_optparam
+
+ use mod_parity
+ use mod_radgeom
+ use mod_sphgeom
+ use mod_artdis
+
+ implicit none
+
+ integer mlu,muu,lu1,lu2,ndu
+ integer mlv,muv,lv,ndv
+
+ integer, dimension(nmx2) :: ipvtua,ipvtub
+ integer, dimension(nmx1) :: ipvtva,ipvtvb
+
+ complex (kind=8), dimension(nmx2,6*nmaxo+4) :: cua1,cub1
+ complex (kind=8), dimension(nmx2,4*nmaxo+3) :: cua2,cub2
+
+ complex (kind=8), dimension(nmx1,6*nmaxo+4) :: cva,cvb
+
+ CONTAINS
+
+c subroutines VMATRIXV for (CVA,CVB), VMATRIXU for (CUA,CUB),
+c BOUNDCV and BOUNDCU for the boundary conditions at ICB and CMB
+
+**********************************************************************
+**********************************************************************
+
+ SUBROUTINE vmatrixv
+
+c This subroutine provides the matrix elements for CVA, CVB
+
+ implicit none
+
+ integer i,j,k,L,L1,LL1,m,n,nmlv,nmlvm,nmlvp,info
+ real (kind=8) dlm,dl1m,c1
+ complex (kind=8) uim
+
+c SUBROUTINE STARTS HERE
+
+c THE BANDWIDTH OF (CVA,CVB)
+
+ mlv = 2*nmaxo+1
+ muv = 2*nmaxo+1
+ lv = 2*mlv+muv+1
+
+ cva = 0.0
+ cvb = 0.0
+
+c THE MATRIX ELEMENTS OF (CVA,CVB) INSIDE THE CORE
+
+
+ do n = 0,nmaxo
+
+ nmlv = n+mlv+1
+ nmlvm= n+mlv+1-nmxo1
+ nmlvp= n+mlv+1+nmxo1
+
+ do m = miner+1,mmax_v
+
+ uim = cmplx(0.0,1.0*m)
+
+ do L1 = 0,lsym_v(m)
+ L = m+2*L1
+ LL1 = LL(L)
+ k = kdm(m-1)-kdm(miner)+2*L1*nmxo1
+ dlm = clm(L,m,1)/(1.0*L)
+ dl1m= clm(L,m,2)/(1.0+L)
+ c1 = ekman*avismv(L,n)
+ do i= 1,nmaxo-1
+ cva(k+i+1,nmlv-i) = -c1*(dch2(n,i)-LL1*
+ & cheb(n,i)/rr(i)**2)-uim*cheb(n,i)/(1.0*LL1)
+ cva(k+i+1,nmlvp-i) = -dl1m*(dch1(n,i)+(L+1)
+ & *cheb(n,i)/rr(i))
+ enddo
+ do i= 2,nmaxo-2
+ cvb(k+i+1,nmlv-i) = c1*(dch4(n,i)-2*LL1
+ & *dch2(n,i)/rr(i)**2+4*LL1*dch1(n,i)/rr(i)**3
+ & +LL1*(LL1-6)*cheb(n,i)/rr(i)**4)+uim*
+ & (dch2(n,i)-LL1*cheb(n,i)/rr(i)**2)/(1.0*LL1)
+ cvb(k+i+1,nmlvp-i) = -dl1m*(dch1(n,i)+(L+1)*
+ & cheb(n,i)/rr(i))
+ enddo
+ if (L1 .gt. 0) then
+ do i= 1,nmaxo-1
+ cva(k+i+1,nmlvm-i) = -dlm*(dch1(n,i)-L*
+ & cheb(n,i)/rr(i))
+ enddo
+ do i= 2,nmaxo-2
+ cvb(k+i+1,nmlvm-i) = -dlm*(dch1(n,i)-L*
+ & cheb(n,i)/rr(i))
+ enddo
+ endif
+ enddo
+
+ do L1 = 0,lsym_v(m)
+ L = m+2*L1+1
+ LL1 = LL(L)
+ k = kdm(m-1)-kdm(miner)+(2*L1+1)*nmxo1
+ dlm = clm(L,m,1)/(1.0*L)
+ dl1m = clm(L,m,2)/(1.0+L)
+ c1 = ekman*avismv(L,n)
+ do i = 2,nmaxo-2
+ cva(k+i+1,nmlvm-i) = -dlm*(dch1(n,i)-L*
+ & cheb(n,i)/rr(i))
+ cva(k+i+1,nmlv-i) = c1*(dch4(n,i)-2*LL1
+ & *dch2(n,i)/rr(i)**2+4*LL1*dch1(n,i)/rr(i)**3
+ & +LL1*(LL1-6)*cheb(n,i)/rr(i)**4)+uim*
+ & (dch2(n,i)-LL1*cheb(n,i)/rr(i)**2)/(1.0*LL1)
+ enddo
+ do i = 1,nmaxo-1
+ cvb(k+i+1,nmlvm-i) = -dlm*(dch1(n,i)-L*
+ & cheb(n,i)/rr(i))
+ cvb(k+i+1,nmlv-i) = -c1*(dch2(n,i)-LL1*
+ & cheb(n,i)/rr(i)**2)-uim*cheb(n,i)/(1.0*LL1)
+ enddo
+ if (L1 .lt. lsym_v(m)) then
+ do i= 2,nmaxo-2
+ cva(k+i+1,nmlvp-i) = -dl1m*(dch1(n,i)+(L+1)*
+ & cheb(n,i)/rr(i))
+ enddo
+ do i= 1,nmaxo-1
+ cvb(k+i+1,nmlvp-i) = -dl1m*(dch1(n,i)+(L+1)*
+ & cheb(n,i)/rr(i))
+ enddo
+ endif
+ enddo
+
+ enddo
+
+ enddo
+
+c THE MATRIX ELEMENTS OF (CVA,CVB) ON THE BOUNDARIES
+
+c The boundary conditions at the ICB and at the CMB
+
+ call boundcv
+
+c LU DECOMPOSITION OF (CVA,CVB)
+
+ ndv = kdm(mmax_v)-kdm(miner)
+
+ call zbandfa(cva,ndv,nmx1,lv,mlv,muv,ipvtva,info)
+ call zbandfa(cvb,ndv,nmx1,lv,mlv,muv,ipvtvb,info)
+
+ END SUBROUTINE vmatrixv
+
+*************************************************************************
+*************************************************************************
+
+ SUBROUTINE vmatrixu
+
+ implicit none
+
+ integer i,j,k,L,L1,LL1,m,n,nmlu,nmlum,nmlup,info
+ real (kind=8) dl0,dl1,c1,c2
+ complex (kind=8) uim
+
+C SUBROUTINE STARTS HERE
+
+ if (itrung .lt. 1) then
+ c1 = 0.25*deltt
+ else if (itrung .lt. 2) then
+ c1 = 0.375*deltt
+ else
+ c1 = 0.5*deltt
+ endif
+
+C THE BANDWIDTH OF CUA,CUB
+
+ mlu = 2*nmaxo+1
+ muu = 2*nmaxo+1
+ lu1 = 2*mlu+muu+1
+ lu2 = mlu+muu+1
+
+ cua1 = 0.0
+ cua2 = 0.0
+ cub1 = 0.0
+ cub2 = 0.0
+
+C MATRIX ELEMNTS OF (CUA1,CUA2,CUB1,CUB2) INSIDE THE CORE
+
+ do n = 0,nmaxo
+
+ nmlu = n+mlu+1
+ nmlum= n+mlu+1-nmxo1
+ nmlup= n+mlu+1+nmxo1
+
+c Matrix elements for m = 0
+
+ do L1 = 1,lsym_v(0)
+ L = 2*L1-1
+ LL1 = LL(L)
+ k = 2*(L1-1)*nmxo1
+ dl0 = clm(L,0,1)/(1.0*L)
+ dl1 = clm(L,0,2)/(1.0+L)
+ c2 = c1*avismv(L,n)*ekman
+ do i= 2,nmaxo-2
+ cua1(k+i+1,nmlu-i) = -ro*(dch2(n,i)-LL1*cheb(n,i)
+ & /rr(i)**2)+c2*(dch4(n,i)-2*LL1*
+ & dch2(n,i)/rr(i)**2+4*LL1*dch1(n,i)/rr(i)**3+
+ & LL1*(LL1-6)*cheb(n,i)/rr(i)**4)
+ cua1(k+i+1,nmlup-i)= -c1*dl1*(dch1(n,i)+(L+1)*
+ & cheb(n,i)/rr(i))
+ cua2(k+i+1,nmlu-i) = -ro*(dch2(n,i)-LL1*cheb(n,i)
+ & /rr(i)**2)-c2*(dch4(n,i)-2*LL1*
+ & dch2(n,i)/rr(i)**2+4*LL1*dch1(n,i)/rr(i)**3+
+ & LL1*(LL1-6)*cheb(n,i)/rr(i)**4)
+ cua2(k+i+1,nmlup-i)= c1*dl1*(dch1(n,i)+(L+1)*
+ & cheb(n,i)/rr(i))
+ enddo
+ do i= 1,nmaxo-1
+ cub1(k+i+1,nmlu-i) = ro*cheb(n,i)-c2*
+ & (dch2(n,i)-LL1*cheb(n,i)/rr(i)**2)
+ cub1(k+i+1,nmlup-i)= -c1*dl1*(dch1(n,i)+(L+1)*
+ & cheb(n,i)/rr(i))
+ cub2(k+i+1,nmlu-i) = ro*cheb(n,i)+c2*
+ & (dch2(n,i)-LL1*cheb(n,i)/rr(i)**2)
+ cub2(k+i+1,nmlup-i)= c1*dl1*(dch1(n,i)+(L+1)*
+ & cheb(n,i)/rr(i))
+ enddo
+ if (L1 .gt. 1) then
+ do i= 2,nmaxo-2
+ cua1(k+i+1,nmlum-i)= -c1*dl0*(dch1(n,i)-L*
+ & cheb(n,i)/rr(i))
+ cua2(k+i+1,nmlum-i)= c1*dl0*(dch1(n,i)-L*
+ & cheb(n,i)/rr(i))
+ enddo
+ do i= 1,nmaxo-1
+ cub1(k+i+1,nmlum-i)= -c1*dl0*(dch1(n,i)-L*
+ & cheb(n,i)/rr(i))
+ cub2(k+i+1,nmlum-i)= c1*dl0*(dch1(n,i)-L*
+ & cheb(n,i)/rr(i))
+ enddo
+ endif
+ enddo
+
+ do L1 = 1,lsym_v(0)
+ L = 2*L1
+ LL1 = LL(L)
+ k = (2*L1-1)*nmxo1
+ dl0 = clm(L,0,1)/(1.0*L)
+ dl1 = clm(L,0,2)/(1.0+L)
+ c2 = c1*avismv(L,n)*ekman
+ do i= 1,nmaxo-1
+ cua1(k+i+1,nmlum-i)= -c1*dl0*(dch1(n,i)-L*
+ & cheb(n,i)/rr(i))
+ cua1(k+i+1,nmlu-i) = ro*cheb(n,i)-c2*
+ & (dch2(n,i)-LL1*cheb(n,i)/rr(i)**2)
+ cua2(k+i+1,nmlum-i)= c1*dl0*(dch1(n,i)-L*
+ & cheb(n,i)/rr(i))
+ cua2(k+i+1,nmlu-i) = ro*cheb(n,i)+c2*
+ & (dch2(n,i)-LL1*cheb(n,i)/rr(i)**2)
+ enddo
+ do i= 2,nmaxo-2
+ cub1(k+i+1,nmlum-i)= -c1*dl0*(dch1(n,i)-L*
+ & cheb(n,i)/rr(i))
+ cub1(k+i+1,nmlu-i) = -ro*(dch2(n,i)-LL1*cheb(n,i)
+ & /rr(i)**2)+c2*(dch4(n,i)-2*LL1*
+ & dch2(n,i)/rr(i)**2+4*LL1*dch1(n,i)/rr(i)**3+
+ & LL1*(LL1-6)*cheb(n,i)/rr(i)**4)
+ cub2(k+i+1,nmlum-i)= c1*dl0*(dch1(n,i)-L*
+ & cheb(n,i)/rr(i))
+ cub2(k+i+1,nmlu-i) = -ro*(dch2(n,i)-LL1*cheb(n,i)
+ & /rr(i)**2)-c2*(dch4(n,i)-2*LL1*
+ & dch2(n,i)/rr(i)**2+4*LL1*dch1(n,i)/rr(i)**3+
+ & LL1*(LL1-6)*cheb(n,i)/rr(i)**4)
+ enddo
+ if (L1 .lt. lsym_v(0)) then
+ do i= 1,nmaxo-1
+ cua1(k+i+1,nmlup-i)= -c1*dl1*(dch1(n,i)+(L+1)*
+ & cheb(n,i)/rr(i))
+ cua2(k+i+1,nmlup-i)= c1*dl1*(dch1(n,i)+(L+1)*
+ & cheb(n,i)/rr(i))
+ enddo
+ do i= 2,nmaxo-2
+ cub1(k+i+1,nmlup-i)= -c1*dl1*(dch1(n,i)+(L+1)*
+ & cheb(n,i)/rr(i))
+ cub2(k+i+1,nmlup-i)= c1*dl1*(dch1(n,i)+(L+1)*
+ & cheb(n,i)/rr(i))
+ enddo
+ endif
+ enddo
+
+c Matrix elements for 1 =< m =< miner
+
+ do m = 1, miner
+
+ uim = c1*cmplx(0.0,1.0*m)
+
+ do L1 = 0,lsym_v(m)
+ L = m+2*L1
+ LL1 = LL(L)
+ k = kdm(m-1)+2*L1*nmxo1
+ dl0 = clm(L,m,1)/(1.0*L)
+ dl1 = clm(L,m,2)/(1.0+L)
+ c2 = c1*ekman*avismv(L,n)
+ do i= 2,nmaxo-2
+ cua1(k+i+1,nmlu-i) = -ro*(dch2(n,i)-LL1*cheb(n,i)
+ & /rr(i)**2)+c2*(dch4(n,i)-2*LL1*dch2(n,i)/
+ & rr(i)**2+4*LL1*dch1(n,i)/rr(i)**3+LL1*(LL1-
+ & 6)*cheb(n,i)/rr(i)**4)+uim*(dch2(n,i)-LL1*
+ & cheb(n,i)/rr(i)**2)/(1.0*LL1)
+ cua1(k+i+1,nmlup-i) = -c1*dl1*(dch1(n,i)+(L+1)*
+ & cheb(n,i)/rr(i))
+ cua2(k+i+1,nmlu-i) = -ro*(dch2(n,i)-LL1*cheb(n,i)
+ & /rr(i)**2)-c2*(dch4(n,i)-2*LL1*dch2(n,i)/
+ & rr(i)**2+4*LL1*dch1(n,i)/rr(i)**3+LL1*(LL1-
+ & 6)*cheb(n,i)/rr(i)**4)-uim*(dch2(n,i)-LL1*
+ & cheb(n,i)/rr(i)**2)/(1.0*LL1)
+ cua2(k+i+1,nmlup-i) = c1*dl1*(dch1(n,i)+(L+1)*
+ & cheb(n,i)/rr(i))
+ enddo
+ do i= 1,nmaxo-1
+ cub1(k+i+1,nmlu-i) = ro*cheb(n,i)-c2*(dch2(n,i)
+ & -LL1*cheb(n,i)/rr(i)**2)-uim*cheb(n,i)/
+ & (1.0*LL1)
+ cub1(k+i+1,nmlup-i) = -c1*dl1*(dch1(n,i)+(L+1)
+ & *cheb(n,i)/rr(i))
+ cub2(k+i+1,nmlu-i) = ro*cheb(n,i)+c2*(dch2(n,i)
+ & -LL1*cheb(n,i)/rr(i)**2)+uim*cheb(n,i)/
+ & (1.0*LL1)
+ cub2(k+i+1,nmlup-i) = c1*dl1*(dch1(n,i)+(L+1)
+ & *cheb(n,i)/rr(i))
+ enddo
+ if (L1 .gt. 0) then
+ do i = 2,nmaxo-2
+ cua1(k+i+1,nmlum-i) = -c1*dl0*(dch1(n,i)-L*
+ & cheb(n,i)/rr(i))
+ cua2(k+i+1,nmlum-i) = c1*dl0*(dch1(n,i)-L*
+ & cheb(n,i)/rr(i))
+ enddo
+ do i = 1,nmaxo-1
+ cub1(k+i+1,nmlum-i) = -c1*dl0*(dch1(n,i)-L*
+ & cheb(n,i)/rr(i))
+ cub2(k+i+1,nmlum-i) = c1*dl0*(dch1(n,i)-L*
+ & cheb(n,i)/rr(i))
+ enddo
+ endif
+ enddo
+
+ do L1 = 0,lsym_v(m)
+ L = m+2*L1+1
+ LL1 = LL(L)
+ k = kdm(m-1)+(2*L1+1)*nmxo1
+ dl0 = clm(L,m,1)/(1.0*L)
+ dl1 = clm(L,m,2)/(1.0+L)
+ c2 = c1*ekman*avismv(L,n)
+ do i= 1,nmaxo-1
+ cua1(k+i+1,nmlum-i) = -c1*dl0*(dch1(n,i)-L*
+ & cheb(n,i)/rr(i))
+ cua1(k+i+1,nmlu-i) = ro*cheb(n,i)-c2*(dch2(n,i)
+ & -LL1*cheb(n,i)/rr(i)**2)-uim*cheb(n,i)/
+ & (1.0*LL1)
+ cua2(k+i+1,nmlum-i) = c1*dl0*(dch1(n,i)-L*
+ & cheb(n,i)/rr(i))
+ cua2(k+i+1,nmlu-i) = ro*cheb(n,i)+c2*(dch2(n,i)
+ & -LL1*cheb(n,i)/rr(i)**2)+uim*cheb(n,i)/
+ & (1.0*LL1)
+ enddo
+ do i= 2,nmaxo-2
+ cub1(k+i+1,nmlum-i) = -c1*dl0*(dch1(n,i)-L*
+ & cheb(n,i)/rr(i))
+ cub1(k+i+1,nmlu-i) = -ro*(dch2(n,i)-LL1*cheb(n,i)
+ & /rr(i)**2)+c2*(dch4(n,i)-2*LL1*dch2(n,i)/
+ & rr(i)**2+4*LL1*dch1(n,i)/rr(i)**3+LL1*(LL1-
+ & 6)*cheb(n,i)/rr(i)**4)+uim*(dch2(n,i)-LL1*
+ & cheb(n,i)/rr(i)**2)/(1.0*LL1)
+ cub2(k+i+1,nmlum-i) = c1*dl0*(dch1(n,i)-L*
+ & cheb(n,i)/rr(i))
+ cub2(k+i+1,nmlu-i) = -ro*(dch2(n,i)-LL1*cheb(n,i)
+ & /rr(i)**2)-c2*(dch4(n,i)-2*LL1*dch2(n,i)/
+ & rr(i)**2+4*LL1*dch1(n,i)/rr(i)**3+LL1*(LL1-
+ & 6)*cheb(n,i)/rr(i)**4)-uim*(dch2(n,i)-LL1*
+ & cheb(n,i)/rr(i)**2)/(1.0*LL1)
+ enddo
+ if (L1 .lt. lsym_v(m)) then
+ do i = 1,nmaxo-1
+ cua1(k+i+1,nmlup-i) = -c1*dl1*(dch1(n,i)+(L+1)*
+ & cheb(n,i)/rr(i))
+ cua2(k+i+1,nmlup-i) = c1*dl1*(dch1(n,i)+(L+1)*
+ & cheb(n,i)/rr(i))
+ enddo
+ do i = 2,nmaxo-2
+ cub1(k+i+1,nmlup-i) = -c1*dl1*(dch1(n,i)+(L+1)*
+ & cheb(n,i)/rr(i))
+ cub2(k+i+1,nmlup-i) = c1*dl1*(dch1(n,i)+(L+1)*
+ & cheb(n,i)/rr(i))
+ enddo
+ endif
+ enddo
+
+ enddo
+
+ enddo
+
+c MATRIX ELEMNTS OF (CUA1,CUA2,CUB1,CUB2) ON THE BOUNDARIES
+
+c The boundary conditions at the ICB
+
+ call boundcu
+
+C LU DECOMPOSITION OF (CUA1,CUB1)
+
+ ndu = kdm(miner)
+
+ call zbandfa(cua1,ndu,nmx2,lu1,mlu,muu,ipvtua,info)
+ call zbandfa(cub1,ndu,nmx2,lu1,mlu,muu,ipvtub,info)
+
+ END SUBROUTINE vmatrixu
+
+*************************************************************************
+*************************************************************************
+
+ SUBROUTINE boundcv
+
+c This subroutine provides the boundary conditions for (COVA,COVB)
+c at ICB and at CMB
+
+ implicit none
+
+ integer i,j,k,L,L1,LL1,m,n,nmlv,nmlvm,nmlvp,info
+ real (kind=8) dlm,dl1m,c1
+ complex (kind=8) uim
+
+c SUBROUTINE STARTS HERE
+
+C
+C Boundary Conditions at ICB
+C
+
+ if (kicbv .eq. 0) then
+
+c Stress-free boundary conditions
+
+ do n = 0,nmax_v
+ nmlv = n+mlv+1
+ do m = miner+1,mmax_v
+ do L1 = 0,lsym_v(m)
+ k = kdm(m-1)-kdm(miner)+2*L1*nmxo1
+ L = kdm(m-1)-kdm(miner)+(2*L1+1)*nmxo1
+ cva(k+1,nmlv) = dch1(n,0)-2.0*cheb(n,0)/rio
+ cvb(k+1,nmlv) = cheb(n,0)
+ cvb(k+2,nmlv-1)= dch2(n,0)-2.0*dch1(n,0)/rio
+ cva(L+1,nmlv) = cheb(n,0)
+ cva(L+2,nmlv-1)= dch2(n,0)-2.0*dch1(n,0)/rio
+ cvb(L+1,nmlv) = dch1(n,0)-2.0*cheb(n,0)/rio
+ enddo
+ enddo
+ enddo
+
+ else if (kicbv .eq. 1) then
+
+c No-slip boundary conditions
+
+ do n = 0,nmax_v
+ nmlv = n+mlv+1
+ do m = miner+1,mmax_v
+ do L1 = 0,lsym_v(m)
+ k = kdm(m-1)-kdm(miner)+2*L1*nmxo1
+ L = kdm(m-1)-kdm(miner)+(2*L1+1)*nmxo1
+ cva(k+1,nmlv) = cheb(n,0)
+ cvb(k+1,nmlv) = cheb(n,0)
+ cvb(k+2,nmlv-1)= dch1(n,0)
+ cva(L+1,nmlv) = cheb(n,0)
+ cva(L+2,nmlv-1)= dch1(n,0)
+ cvb(L+1,nmlv) = cheb(n,0)
+ enddo
+ enddo
+ enddo
+
+ else if (kicbv .eq. 2) then
+
+c Partial-slippery boundary conditions
+
+ do n = 0,nmax_v
+ nmlv = n+mlv+1
+ nmlvm= n+mlv+1-nmxo1
+ nmlvp= n+mlv+1+nmxo1
+ do m = miner+1,mmax_v
+ uim = cmplx(0.0,1.0*m)
+ do L1 = 0,lsym_v(m)
+ L = m+2*L1
+ LL1 = LL(L)
+ k = kdm(m-1)-kdm(miner)+2*L1*nmxo1
+ dlm = clm(L,m,1)/(1.0*L)
+ dl1m= clm(L,m,2)/(1.0+L)
+ cva(k+1,nmlv) = dch1(n,0)-((1.0+1.0/rio)-
+ & uim/(1.0*LL1))*cheb(n,0)
+ cva(k+1,nmlvp) = dl1m*dch1(n,0)
+ cvb(k+1,nmlv) = cheb(n,0)
+ cvb(k+2,nmlv-1) = dch2(n,0)-((1.0+1.0/rio)-
+ & uim/(1.0*LL1))*dch1(n,0)
+ cvb(k+2,nmlvp-1)= -dl1m*cheb(n,0)
+ if (L1 .gt. 0) then
+ cva(k+1,nmlvm) = dlm*dch1(n,0)
+ cvb(k+2,nmlvm-1)= -dlm*cheb(n,0)
+ endif
+ enddo
+ do L1 = 0,lsym_v(m)
+ L = m+2*L1+1
+ LL1 = LL(L)
+ k = kdm(m-1)-kdm(miner)+(2*L1+1)*nmxo1
+ dlm = clm(L,m,1)/(1.0*L)
+ dl1m= clm(L,m,2)/(1.0+L)
+ cva(k+1,nmlv) = cheb(n,0)
+ cva(k+2,nmlv-1) = dch2(n,0)-((1.0+1.0/rio)-
+ & uim/(1.0*LL1))*dch1(n,0)
+ cva(k+2,nmlvm-1)= -dlm*cheb(n,0)
+ cvb(k+1,nmlv) = dch1(n,0)-((1.0+1.0/rio)-
+ & uim/(1.0*LL1))*cheb(n,0)
+ cvb(k+1,nmlvm) = dlm*dch1(n,0)
+ if (L1 .lt. lsym_v(m)) then
+ cva(k+2,nmlvp-1)= -dl1m*cheb(n,0)
+ cvb(k+1,nmlvp) = dl1m*dch1(n,0)
+ endif
+ enddo
+ enddo
+ enddo
+
+ endif
+
+C
+C Boundary Conditions at CMB
+C
+
+ if (kcmbv .eq. 0) then
+
+c Stress-free boundary conditions
+
+ do n = 0,nmax_v
+ nmlv = n+mlv+1-nmxo1
+ do m = miner+1,mmax_v
+ do L1 = 0,lsym_v(m)
+ k = kdm(m-1)-kdm(miner)+2*L1*nmxo1
+ L = kdm(m-1)-kdm(miner)+(2*L1+1)*nmxo1
+ cva(k+nmxo1,nmlv+1)= dch1(n,nmaxo)-2.0*cheb(n,nmaxo)
+ cvb(k+nmaxo,nmlv+2)= dch2(n,nmaxo)-2.0*dch1(n,nmaxo)
+ cvb(k+nmxo1,nmlv+1)= cheb(n,nmaxo)
+ cva(L+nmaxo,nmlv+2)= dch2(n,nmaxo)-2.0*dch1(n,nmaxo)
+ cva(L+nmxo1,nmlv+1)= cheb(n,nmaxo)
+ cvb(L+nmxo1,nmlv+1)= dch1(n,nmaxo)-2.0*cheb(n,nmaxo)
+ enddo
+ enddo
+ enddo
+
+ else if (kcmbv .eq. 1) then
+
+c No-slip boundary conditions
+
+ do n = 0,nmax_v
+ nmlv = n+mlv+1-nmxo1
+ do m = miner+1,mmax_v
+ do L1 = 0,lsym_v(m)
+ k = kdm(m-1)-kdm(miner)+2*L1*nmxo1
+ L = kdm(m-1)-kdm(miner)+(2*L1+1)*nmxo1
+ cva(k+nmxo1,nmlv+1)= cheb(n,nmaxo)
+ cvb(k+nmaxo,nmlv+2)= dch1(n,nmaxo)
+ cvb(k+nmxo1,nmlv+1)= cheb(n,nmaxo)
+ cva(L+nmaxo,nmlv+2)= dch1(n,nmaxo)
+ cva(L+nmxo1,nmlv+1)= cheb(n,nmaxo)
+ cvb(L+nmxo1,nmlv+1)= cheb(n,nmaxo)
+ enddo
+ enddo
+ enddo
+
+ else if (kcmbv .eq. 2) then
+
+c Partial slippery boundary conditions
+
+ do n = 0,nmax_v
+ nmlv = n+mlv+1
+ nmlvm= n+mlv+1-nmxo1
+ do m = miner+1,mmax_v
+ uim = cmplx(0.0,1.0*m)
+ do L1 = 0,lsym_v(m)
+ L = m+2*L1
+ LL1 = LL(L)
+ k = kdm(m-1)-kdm(miner)+(2*L1+1)*nmxo1
+ dlm = clm(L,m,1)/(1.0*L)
+ dl1m= clm(L,m,2)/(1.0+L)
+ cva(k,nmlvm+1) = dch1(n,nmaxo)-uim/
+ & (1.0*LL1)*cheb(n,nmaxo)
+ cva(k,nmlv+1) = -dl1m*dch1(n,nmaxo)
+ cvb(k-1,nmlvm+2)= dch2(n,nmaxo)-uim/
+ & (1.0*LL1)*dch1(n,nmaxo)
+ cvb(k-1,nmlv+2) = dl1m*cheb(n,nmaxo)
+ cvb(k,nmlvm+1) = cheb(n,nmaxo)
+ if (L1 .gt. 0) then
+ cva(k,nmlvm-nmaxo) = -dlm*dch1(n,nmaxo)
+ cvb(k-1,nmlvm-nmaxo+1)= dlm*cheb(n,nmaxo)
+ endif
+ enddo
+ do L1 = 0,lsym_v(m)
+ L = m+2*L1+1
+ LL1 = LL(L)
+ k = kdm(m-1)-kdm(miner)+2*(L1+1)*nmxo1
+ dlm = clm(L,m,1)/(1.0*L)
+ dl1m= clm(L,m,2)/(1.0+L)
+ cva(k-1,nmlvm+2) = dch2(n,nmaxo)-uim/
+ & (1.0*LL1)*dch1(n,nmaxo)
+ cva(k-1,nmlvm-nmaxo+1)= dlm*cheb(n,nmaxo)
+ cva(k,nmlvm+1) = cheb(n,nmaxo)
+ cvb(k,nmlvm+1) = dch1(n,nmaxo)-uim/
+ & (1.0*LL1)*cheb(n,nmaxo)
+ cvb(k,nmlvm-nmaxo)= -dlm*dch1(n,nmaxo)
+ if (L1 .lt. lsym_v(m)) then
+ cva(k-1,nmlv+2)= dl1m*cheb(n,nmaxo)
+ cvb(k,nmlv+1) = -dl1m*dch1(n,nmaxo)
+ endif
+ enddo
+ enddo
+ enddo
+
+ endif
+
+ END SUBROUTINE boundcv
+
+*************************************************************************
+*************************************************************************
+
+ SUBROUTINE boundcu
+
+c This subroutine provides the boundary conditions for (COUA,COUB)
+c at ICB and at CMB
+
+ implicit none
+
+ integer i,j,k,L,L1,LL1,m,n,nmlu,nmlum,nmlup,info
+ real (kind=8) dl0,dl1,c1
+ complex (kind=8) uim
+
+c SUBROUTINE STARTS HERE
+
+C
+C Boundary Conditions at ICB
+C
+
+ if (kicbv .eq. 0) then
+
+c Stress-free boundary conditions
+
+ do n = 0,nmax_v
+ nmlu = n+mlu+1
+ do L1 = 1,lsym_v(0)
+ k = 2*(L1-1)*nmxo1
+ L = (2*L1-1)*nmxo1
+ cua1(k+1,nmlu) = cheb(n,0)
+ cua1(k+2,nmlu-1)= dch2(n,0)-2.0*dch1(n,0)/rio
+ cub1(k+1,nmlu) = dch1(n,0)-2.0*cheb(n,0)/rio
+ cua1(L+1,nmlu) = dch1(n,0)-2.0*cheb(n,0)/rio
+ cub1(L+1,nmlu) = cheb(n,0)
+ cub1(L+2,nmlu-1)= dch2(n,0)-2.0*dch1(n,0)/rio
+ enddo
+ do m = 1,miner
+ do L1 = 0,lsym_v(m)
+ k = kdm(m-1)+2*L1*nmxo1
+ L = kdm(m-1)+(2*L1+1)*nmxo1
+ cua1(k+1,nmlu) = cheb(n,0)
+ cua1(k+2,nmlu-1)= dch2(n,0)-2.0*dch1(n,0)/rio
+ cub1(k+1,nmlu) = dch1(n,0)-2.0*cheb(n,0)/rio
+ cua1(L+1,nmlu) = dch1(n,0)-2.0*cheb(n,0)/rio
+ cub1(L+1,nmlu) = cheb(n,0)
+ cub1(L+2,nmlu-1)= dch2(n,0)-2.0*dch1(n,0)/rio
+ enddo
+ enddo
+ enddo
+
+ else if (kicbv .eq. 1) then
+
+c No-slip boundary conditions
+
+ do n = 0,nmax_v
+ nmlu = n+mlu+1
+ do L1 = 1,lsym_v(0)
+ k = 2*(L1-1)*nmxo1
+ L = (2*L1-1)*nmxo1
+ cua1(k+1,nmlu) = cheb(n,0)
+ cua1(k+2,nmlu-1)= dch1(n,0)
+ cub1(k+1,nmlu) = cheb(n,0)
+ cua1(L+1,nmlu) = cheb(n,0)
+ cub1(L+1,nmlu) = cheb(n,0)
+ cub1(L+2,nmlu-1)= dch1(n,0)
+ enddo
+ do m = 1,miner
+ do L1= 0,lsym_v(m)
+ k = kdm(m-1)+2*L1*nmxo1
+ L = kdm(m-1)+(2*L1+1)*nmxo1
+ cua1(k+1,nmlu) = cheb(n,0)
+ cua1(k+2,nmlu-1)= dch1(n,0)
+ cub1(k+1,nmlu) = cheb(n,0)
+ cua1(L+1,nmlu) = cheb(n,0)
+ cub1(L+1,nmlu) = cheb(n,0)
+ cub1(L+2,nmlu-1)= dch1(n,0)
+ enddo
+ enddo
+ enddo
+
+ else if (kicbv .eq. 2) then
+
+c Partial-slippery boundary conditions
+
+ do n = 0,nmax_v
+ nmlu = n+mlu+1
+ nmlum= n+mlu+1-nmxo1
+ nmlup= n+mlu+1+nmxo1
+ do L1= 1,lsym_v(0)
+ L = 2*L1-1
+ LL1 = LL(L)
+ k = 2*(L1-1)*nmxo1
+ dl0 = clm(L,0,1)/(1.0*L)
+ dl1 = clm(L,0,2)/(1.0+L)
+ cua1(k+1,nmlu) = cheb(n,0)
+ cua1(k+2,nmlu-1) = dch2(n,0)-(1.0+1.0/rio)*
+ & dch1(n,0)
+ cua1(k+2,nmlup-1)= -dl1*cheb(n,0)
+ cub1(k+1,nmlu) = dch1(n,0)-(1.0+1.0/rio)*
+ & cheb(n,0)
+ cub1(k+1,nmlup) = dl1*dch1(n,0)
+ if (L1 .gt. 1) then
+ cua1(k+2,nmlum-1)= -dl0*cheb(n,0)
+ cub1(k+1,nmlum) = dl0*dch1(n,0)
+ endif
+ enddo
+ do L1= 1,lsym_v(0)
+ L = 2*L1
+ LL1 = LL(L)
+ k = (2*L1-1)*nmxo1
+ dl0 = clm(L,0,1)/(1.0*L)
+ dl1 = clm(L,0,2)/(1.0+L)
+ cua1(k+1,nmlu) = dch1(n,0)-(1.0+1.0/rio)*
+ & cheb(n,0)
+ cua1(k+1,nmlum) = dl0*dch1(n,0)
+ cub1(k+1,nmlu) = cheb(n,0)
+ cub1(k+2,nmlu-1) = dch2(n,0)-(1.0+1.0/rio)*
+ & dch1(n,0)
+ cub1(k+2,nmlum-1)= -dl0*cheb(n,0)
+ if (L1 .lt. lsym_v(0)) then
+ cua1(k+1,nmlup) = dl1*dch1(n,0)
+ cub1(k+2,nmlup-1)= -dl1*cheb(n,0)
+ endif
+ enddo
+ do m = 1,miner
+ uim = cmplx(0.0,1.0*m)
+ do L1= 0,lsym_v(m)
+ L = m+2*L1
+ LL1 = LL(L)
+ k = kdm(m-1)+2*L1*nmxo1
+ dl0 = clm(L,m,1)/(1.0*L)
+ dl1 = clm(L,m,2)/(1.0+L)
+ cua1(k+1,nmlu) = cheb(n,0)
+ cua1(k+2,nmlu-1) = dch2(n,0)-((1.0+1.0/rio)-uim
+ & /(1.0*LL1))*dch1(n,0)
+ cua1(k+2,nmlup-1)= -dl1*cheb(n,0)
+ cub1(k+1,nmlu) = dch1(n,0)-((1.0+1.0/rio)-uim
+ & /(1.0*LL1))*cheb(n,0)
+ cub1(k+1,nmlup) = dl1*dch1(n,0)
+ if (L1 .gt. 0) then
+ cua1(k+2,nmlum-1)= -dl0*cheb(n,0)
+ cub1(k+1,nmlum) = dl0*dch1(n,0)
+ endif
+ enddo
+ do L1 = 0,lsym_v(m)
+ L = m+2*L1+1
+ LL1= LL(L)
+ k = kdm(m-1)+(2*L1+1)*nmxo1
+ dl0= clm(L,m,1)/(1.0*L)
+ dl1= clm(L,m,2)/(1.0+L)
+ cua1(k+1,nmlu) = dch1(n,0)-((1.0+1.0/rio)-uim
+ & /(1.0*LL1))*cheb(n,0)
+ cua1(k+1,nmlum) = dl0*dch1(n,0)
+ cub1(k+1,nmlu) = cheb(n,0)
+ cub1(k+2,nmlu-1) = dch2(n,0)-((1.0+1.0/rio)-uim
+ & /(1.0*LL1))*dch1(n,0)
+ cub1(k+2,nmlum-1)= -dl0*cheb(n,0)
+ if (L1 .lt. lsym_v(m)) then
+ cua1(k+1,nmlup) = dl1*dch1(n,0)
+ cub1(k+2,nmlup-1)= -dl1*cheb(n,0)
+ endif
+ enddo
+ enddo
+ enddo
+
+ endif
+
+C
+C Boundary Conditions at CMB
+C
+
+ if (kcmbv .eq. 0) then
+
+c Stress-free boundary conditions
+
+ i = nmaxo
+
+ do n = 0,nmax_v
+ nmlu = n+mlu+1-nmxo1
+ do L1 = 1,lsym_v(0)
+ k = 2*(L1-1)*nmxo1
+ L = (2*L1-1)*nmxo1
+ cua1(k+nmaxo,nmlu+2)= dch2(n,i)-2.0*dch1(n,i)
+ cua1(k+nmxo1,nmlu+1)= cheb(n,i)
+ cub1(k+nmxo1,nmlu+1)= dch1(n,i)-2.0*cheb(n,i)
+ cua1(L+nmxo1,nmlu+1)= dch1(n,i)-2.0*cheb(n,i)
+ cub1(L+nmaxo,nmlu+2)= dch2(n,i)-2.0*dch1(n,i)
+ cub1(L+nmxo1,nmlu+1)= cheb(n,i)
+ enddo
+ do m = 1,miner
+ do L1= 0,lsym_v(m)
+ k = kdm(m-1)+2*L1*nmxo1
+ L = kdm(m-1)+(2*L1+1)*nmxo1
+ cua1(k+nmaxo,nmlu+2)= dch2(n,i)-2.0*dch1(n,i)
+ cua1(k+nmxo1,nmlu+1)= cheb(n,i)
+ cub1(k+nmxo1,nmlu+1)= dch1(n,i)-2.0*cheb(n,i)
+ cua1(L+nmxo1,nmlu+1)= dch1(n,i)-2.0*cheb(n,i)
+ cub1(L+nmaxo,nmlu+2)= dch2(n,i)-2.0*dch1(n,i)
+ cub1(L+nmxo1,nmlu+1)= cheb(n,i)
+ enddo
+ enddo
+ enddo
+
+ else if (kcmbv .eq. 1) then
+
+c No-slip boundary conditions
+
+ do n = 0,nmax_v
+ nmlu = n+mlu+1-nmxo1
+ do L1 = 1,lsym_v(0)
+ k = 2*(L1-1)*nmxo1
+ L = (2*L1-1)*nmxo1
+ cua1(k+nmaxo,nmlu+2)= dch1(n,nmaxo)
+ cua1(k+nmxo1,nmlu+1)= cheb(n,nmaxo)
+ cub1(k+nmxo1,nmlu+1)= cheb(n,nmaxo)
+ cua1(L+nmxo1,nmlu+1)= cheb(n,nmaxo)
+ cub1(L+nmaxo,nmlu+2)= dch1(n,nmaxo)
+ cub1(L+nmxo1,nmlu+1)= cheb(n,nmaxo)
+ enddo
+ do m = 1,miner
+ do L1= 0,lsym_v(m)
+ k = kdm(m-1)+2*L1*nmxo1
+ L = kdm(m-1)+(2*L1+1)*nmxo1
+ cua1(k+nmaxo,nmlu+2)= dch1(n,nmaxo)
+ cua1(k+nmxo1,nmlu+1)= cheb(n,nmaxo)
+ cub1(k+nmxo1,nmlu+1)= cheb(n,nmaxo)
+ cua1(L+nmxo1,nmlu+1)= cheb(n,nmaxo)
+ cub1(L+nmaxo,nmlu+2)= dch1(n,nmaxo)
+ cub1(L+nmxo1,nmlu+1)= cheb(n,nmaxo)
+ enddo
+ enddo
+ enddo
+
+ else if (kcmbv .eq. 2) then
+
+c Partial-slippery boundary conditions
+
+ do n = 0,nmax_v
+ nmlu = n+mlu+1
+ nmlum= n+mlu+1-nmxo1
+ nmlup= n+mlu+1+nmxo1
+ do L1= 1,lsym_v(0)
+ L = 2*L1-1
+ LL1 = LL(L)
+ k = (2*L1-1)*nmxo1
+ dl0 = clm(L,0,1)/(1.0*L)
+ dl1 = clm(L,0,2)/(1.0+L)
+ cua1(k-1,nmlum+2)= dch2(n,nmaxo)
+ cua1(k-1,nmlu+2) = dl1*cheb(n,nmaxo)
+ cua1(k,nmlum+1) = cheb(n,nmaxo)
+ cub1(k,nmlum+1) = dch1(n,nmaxo)
+ cub1(k,nmlu+1) = -dl1*dch1(n,nmaxo)
+ if (L1 .gt. 1) then
+ cua1(k-1,nmlum-nmaxo+1)= dl0*cheb(n,nmaxo)
+ cub1(k,nmlum-nmaxo) = -dl0*dch1(n,nmaxo)
+ endif
+ enddo
+ do L1= 1,lsym_v(0)
+ L = 2*L1
+ LL1 = LL(L)
+ k = 2*L1*nmxo1
+ dl0 = clm(L,0,1)/(1.0*L)
+ dl1 = clm(L,0,2)/(1.0+L)
+ cua1(k,nmlum+1) = dch1(n,nmaxo)
+ cua1(k,nmlum-nmaxo)= -dl0*dch1(n,nmaxo)
+ cub1(k-1,nmlum+2) = dch2(n,nmaxo)
+ cub1(k-1,nmlum-nmaxo+1)= dl0*cheb(n,nmaxo)
+ cub1(k,nmlum+1) = cheb(n,nmaxo)
+ if (L1 .lt. lsym_v(0)) then
+ cua1(k,nmlu+1) = -dl1*dch1(n,nmaxo)
+ cub1(k-1,nmlu+2)= dl1*cheb(n,nmaxo)
+ endif
+ enddo
+ do m = 1,miner
+ uim = cmplx(0.0,1.0*m)
+ do L1= 0,lsym_v(m)
+ L = m+2*L1
+ LL1 = LL(L)
+ k = kdm(m-1)+(2*L1+1)*nmxo1
+ dl0 = clm(L,m,1)/(1.0*L)
+ dl1 = clm(L,m,2)/(1.0+L)
+ cua1(k-1,nmlum+2)= dch2(n,nmaxo)-uim/(1.0*LL1)
+ & *dch1(n,nmaxo)
+ cua1(k-1,nmlu+2) = dl1*cheb(n,nmaxo)
+ cua1(k,nmlum+1) = cheb(n,nmaxo)
+ cub1(k,nmlum+1) = dch1(n,nmaxo)-uim/(1.0*LL1)
+ & *cheb(n,nmaxo)
+ cub1(k,nmlu+1) = -dl1*dch1(n,nmaxo)
+ if (L1 .gt. 0) then
+ cua1(k-1,nmlum-nmaxo+1)= dl0*cheb(n,nmaxo)
+ cub1(k,nmlum-nmaxo) = -dl0*dch1(n,nmaxo)
+ endif
+ enddo
+ do L1 = 0,lsym_v(m)
+ L = m+2*L1+1
+ LL1= LL(L)
+ k = kdm(m-1)+2*(L1+1)*nmxo1
+ dl0= clm(L,m,1)/(1.0*L)
+ dl1= clm(L,m,2)/(1.0+L)
+ cua1(k,nmlum+1) = dch1(n,nmaxo)-uim/(1.0*LL1)
+ & *cheb(n,nmaxo)
+ cua1(k,nmlum-nmaxo)= -dl0*dch1(n,nmaxo)
+ cub1(k-1,nmlum+2) = dch2(n,nmaxo)-uim/(1.0*LL1)
+ & *dch1(n,nmaxo)
+ cub1(k-1,nmlum-nmaxo+1)= dl0*cheb(n,nmaxo)
+ cub1(k,nmlum+1) = cheb(n,nmaxo)
+ if (L1 .lt. lsym_v(m)) then
+ cua1(k,nmlu+1) = -dl1*dch1(n,nmaxo)
+ cub1(k-1,nmlu+2)= dl1*cheb(n,nmaxo)
+ endif
+ enddo
+ enddo
+ enddo
+
+ endif
+
+ END SUBROUTINE boundcu
+
+*************************************************************************
+*************************************************************************
+
+ END MODULE mod_vmatrix
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+c
+c This module defines the matrices for the induction equation
+c that solves the magnetic field
+c
+c (CB1, CB2): the matrices for the poloidal field;
+c MLB: the # of diagonals below the main diagonal;
+c MUB: the # of diagonals above the main diagonal;
+c LB1 = 2*MLB+MUB+1;
+c LB2 = MLB+MUB+1;
+c IPVTB: the pivoting index for CB1;
+c
+c (CJ1, CJ2): the matrices for the toroidal field;
+c MLJ: the # of diagonals below the main diagonal;
+c MUJ: the # of diagonals above the main diagonal;
+c LJ1 = 2*MLJ+MUJ+1;
+c LJ2 = MLJ+MUJ+1;
+c IPVTJ: the pivoting index for CJ1;
+c
+c NMX6: the leading dimension of (CB, CJ);
+c
+c Author: Weijia Kuang
+c Date: Feb., 2001
+c COPY RIGHT: THIS CODE CAN NOT BE DUPLICATED OR USED WITHOUT
+c THE PERMISSION OF THE AUTHOR.
+c
+
+ MODULE mod_bmatrix
+
+ use mod_dimparam
+ use mod_sysparam
+ use mod_numparam
+ use mod_optparam
+
+ use mod_parity
+ use mod_radgeom
+ use mod_sphgeom
+ use mod_artdis
+
+ implicit none
+
+ integer mlb,mub,lb1,lb2
+ integer mlj,muj,lj1,lj2
+
+ integer, dimension(nmx6,Lmax_m) :: ipvtb,ipvtj
+
+ complex (kind=8), dimension(nmx6,13,Lmax_m) :: cb1,cj1
+ complex (kind=8), dimension(nmx6,9,Lmax_m) :: cb2,cj2
+
+ CONTAINS
+
+c a subroutine that defines the matrices
+
+**************************************************************************
+**************************************************************************
+
+ SUBROUTINE bmatrix
+
+ implicit none
+
+ integer i,k,L,LL1,n,info
+ real (kind=8) rmi,ct,c1,c2,c3,hni,hno,hnm
+
+C SUBROUTINE STARTS HERE
+
+ if (itrung .lt. 1) then
+ ct = 0.25*deltt
+ else if (itrung .lt. 2) then
+ ct = 0.375*deltt
+ else
+ ct = 0.5*deltt
+ endif
+
+ rmi = 1.0/rm
+ hno = -nmaxo/pi
+ hni = 1.0*nmaxi
+ hnm = 1.0*nmaxm
+
+ mlb = 4
+ mub = 4
+ lb1 = 2*mlb+mub+1
+ lb2 = mlb+mub+1
+
+ mlj = 4
+ muj = 4
+ lj1 = 2*mlj+muj+1
+ lj2 = mlj+muj+1
+
+ cb1 = 0.0
+ cb2 = 0.0
+ cj1 = 0.0
+ cj2 = 0.0
+
+C THE MATRIX ELEMNTS FOR (CB1,CB2,CJ1,CJ2)
+
+c (1) The matrix elements for a finitely conducting inner core
+
+ if (kicbb .gt. 1) then
+
+ do L = 1,Lmax_m
+
+ LL1= LL(L)
+ c1 = ct*rmi*etaio*avismb(L)
+
+c Boundary conditions near the central core
+
+ if (kccbb .eq. 0) then
+
+c-------------------perfectly insulating central region
+
+ cb1(1,mlb+1,L)= -(L+1)/rco
+ cb1(1,mlb+2,L)= 1.0
+ cj1(1,mlj+1,L)= 1.0
+
+ else if (kccbb .eq. 1) then
+
+c-------------------Asymptotic boundary conditions near the center
+
+ cb1(1,mlb+1,L) = -(L+1)/rco
+ cb1(1,mlb+2,L) = 1.0
+ cj1(1,mlj+1,L) = -(L+1)/rco
+ cj1(1,mlj+2,L) = 1.0
+
+ endif
+
+c----------------Equations in the finitely conduction inner core
+
+ i = 0
+ n = 2*i+2
+ cb1(n,mlb,L) = -0.5*hni
+ cb1(n,mlb+1,L) = -gi(i)/6.0
+ cb1(n,mlb+3,L) = -2.0*gi(i+1)/3.0
+ cb1(n,mlb+4,L) = 0.5*hni
+ cb1(n,mlb+5,L) = -gi(i+2)/6.0
+ cb1(n+1,mlb-1,L)= gi(i)*(1.0+c1*LL1/ri(i)**2)/6.0
+ cb1(n+1,mlb,L) = 0.5*c1*hni
+ cb1(n+1,mlb+1,L)= 2.0*gi(i+1)*(1.0+c1*LL1/ri(i+1)**2)/3.0
+ cb1(n+1,mlb+3,L)= gi(i+2)*(1.0+c1*LL1/ri(i+2)**2)/6.0
+ cb1(n+1,mlb+4,L)= -0.5*c1*hni
+ cb2(n+1,mlb-1,L)= gi(i)*(1.0-c1*LL1/ri(i)**2)/6.0
+ cb2(n+1,mlb,L) = -0.5*c1*hni
+ cb2(n+1,mlb+1,L)= 2.0*gi(i+1)*(1.0-c1*LL1/ri(i+1)**2)/3.0
+ cb2(n+1,mlb+3,L)= gi(i+2)*(1.0-c1*LL1/ri(i+2)**2)/6.0
+ cb2(n+1,mlb+4,L)= 0.5*c1*hni
+ cj1(n,mlj,L) = -0.5*hni
+ cj1(n,mlj+1,L) = -gi(i)/6.0
+ cj1(n,mlj+3,L) = -2.0*gi(i+1)/3.0
+ cj1(n,mlj+4,L) = 0.5*hni
+ cj1(n,mlj+5,L) = -gi(i+2)/6.0
+ cj1(n+1,mlj-1,L)= gi(i)*(1.0+c1*LL1/ri(i)**2)/6.0
+ cj1(n+1,mlj,L) = 0.5*c1*hni
+ cj1(n+1,mlj+1,L)= 2.0*gi(i+1)*(1.0+c1*LL1/ri(i+1)**2)/3.0
+ cj1(n+1,mlj+3,L)= gi(i+2)*(1.0+c1*LL1/ri(i+1)**2)/6.0
+ cj1(n+1,mlj+4,L)= -0.5*c1*hni
+ cj2(n+1,mlj-1,L)= gi(i)*(1.0-c1*LL1/ri(i)**2)/6.0
+ cj2(n+1,mlj,L) = -0.5*c1*hni
+ cj2(n+1,mlj+1,L)= 2.0*gi(i+1)*(1.0-c1*LL1/ri(i+1)**2)/3.0
+ cj2(n+1,mlj+3,L)= gi(i+2)*(1.0-c1*LL1/ri(i+2)**2)/6.0
+ cj2(n+1,mlj+4,L)= 0.5*c1*hni
+ do i = 1,nmaxi-3
+ n = 2*i+2
+ cb1(n,mlb-2,L) = -hni/12.0
+ cb1(n,mlb,L) = -9.0*hni/12.0
+ cb1(n,mlb+1,L) = -0.5*gi(i)
+ cb1(n,mlb+2,L) = 9.0*hni/12.0
+ cb1(n,mlb+3,L) = -0.5*gi(i+1)
+ cb1(n,mlb+4,L) = hni/12.0
+ cb1(n+1,mlb-2,L)= c1*hni/12.0
+ cb1(n+1,mlb-1,L)= 0.5*gi(i)*(1.0+c1*LL1/ri(i)**2)
+ cb1(n+1,mlb,L) = 9.0*c1*hni/12.0
+ cb1(n+1,mlb+1,L)= 0.5*gi(i+1)*(1.0+c1*LL1/ri(i+1)**2)
+ cb1(n+1,mlb+2,L)= -9.0*c1*hni/12.0
+ cb1(n+1,mlb+4,L)= -c1*hni/12.0
+ cb2(n+1,mlb-2,L)= -c1*hni/12.0
+ cb2(n+1,mlb-1,L)= 0.5*gi(i)*(1.0-c1*LL1/ri(i)**2)
+ cb2(n+1,mlb,L) = -9.0*c1*hni/12.0
+ cb2(n+1,mlb+1,L)= 0.5*gi(i+1)*(1.0-c1*LL1/ri(i+1)**2)
+ cb2(n+1,mlb+2,L)= 9.0*c1*hni/12.0
+ cb2(n+1,mlb+4,L)= c1*hni/12.0
+ cj1(n,mlj-2,L) = -hni/12.0
+ cj1(n,mlj,L) = -9.0*hni/12.0
+ cj1(n,mlj+1,L) = -0.5*gi(i)
+ cj1(n,mlj+2,L) = 9.0*hni/12.0
+ cj1(n,mlj+3,L) = -0.5*gi(i+1)
+ cj1(n,mlj+4,L) = hni/12.0
+ cj1(n+1,mlj-2,L)= c1*hni/12.0
+ cj1(n+1,mlj-1,L)= 0.5*gi(i)*(1.0+c1*LL1/ri(i)**2)
+ cj1(n+1,mlj,L) = 9.0*c1*hni/12.0
+ cj1(n+1,mlj+1,L)= 0.5*gi(i+1)*(1.0+c1*LL1/ri(i+1)**2)
+ cj1(n+1,mlj+2,L)= -9.0*c1*hni/12.0
+ cj1(n+1,mlj+4,L)= -c1*hni/12.0
+ cj2(n+1,mlj-2,L)= -c1*hni/12.0
+ cj2(n+1,mlj-1,L)= 0.5*gi(i)*(1.0-c1*LL1/ri(i)**2)
+ cj2(n+1,mlj,L) = -9.0*c1*hni/12.0
+ cj2(n+1,mlj+1,L)= 0.5*gi(i+1)*(1.0-c1*LL1/ri(i+1)**2)
+ cj2(n+1,mlj+2,L)= 9.0*c1*hni/12.0
+ cj2(n+1,mlj+4,L)= c1*hni/12.0
+ enddo
+ i = nmaxi-2
+ n = 2*i+2
+ cb1(n,mlb,L) = cfm(1,1)
+ cb1(n,mlb+1,L) = -cfm(4,1)
+ cb1(n,mlb+2,L) = cfm(2,1)
+ cb1(n,mlb+3,L) = -cfm(5,1)
+ cb1(n,mlb+4,L) = cfm(3,1)
+ cb1(n+1,mlb-1,L) = cfm(4,1)*(1.0+c1*LL1/ri(i)**2)
+ cb1(n+1,mlb,L) = -c1*cfm(1,1)
+ cb1(n+1,mlb+1,L) = cfm(5,1)*(1.0+c1*LL1/ri(i+1)**2)
+ cb1(n+1,mlb+2,L) = -c1*cfm(2,1)
+ cb1(n+1,mlb+4,L) = -c1*cfm(3,1)
+ cb2(n+1,mlb-1,L) = cfm(4,1)*(1.0-c1*LL1/ri(i)**2)
+ cb2(n+1,mlb,L) = c1*cfm(1,1)
+ cb2(n+1,mlb+1,L) = cfm(5,1)*(1.0-c1*LL1/ri(i+1)**2)
+ cb2(n+1,mlb+2,L) = c1*cfm(2,1)
+ cb2(n+1,mlb+4,L) = c1*cfm(3,1)
+ cj1(n,mlj,L) = cfm(1,1)
+ cj1(n,mlj+1,L) = -cfm(4,1)
+ cj1(n,mlj+2,L) = cfm(2,1)
+ cj1(n,mlj+3,L) = -cfm(5,1)
+ cj1(n,mlj+4,L) = cfm(3,1)
+ cj1(n+1,mlj-1,L) = cfm(4,1)*(1.0+c1*LL1/ri(i)**2)
+ cj1(n+1,mlj,L) = -c1*cfm(1,1)
+ cj1(n+1,mlj+1,L) = cfm(5,1)*(1.0+c1*LL1/ri(i+1)**2)
+ cj1(n+1,mlj+2,L) = -c1*cfm(2,1)
+ cj1(n+1,mlj+4,L) = -c1*cfm(3,1)
+ cj2(n+1,mlj-1,L) = cfm(4,1)*(1.0-c1*LL1/ri(i)**2)
+ cj2(n+1,mlj,L) = c1*cfm(1,1)
+ cj2(n+1,mlj+1,L) = cfm(5,1)*(1.0-c1*LL1/ri(i+1)**2)
+ cj2(n+1,mlj+2,L) = c1*cfm(2,1)
+ cj2(n+1,mlj+4,L) = c1*cfm(3,1)
+ i = nmaxi-1
+ n = 2*i+2
+ cb1(n,mlb-2,L) = cfm(1,2)
+ cb1(n,mlb,L) = cfm(2,2)
+ cb1(n,mlb+1,L) = -cfm(4,2)
+ cb1(n,mlb+2,L) = cfm(3,2)
+ cb1(n,mlb+3,L) = -cfm(5,2)
+ cb1(n+1,mlb-2,L) = -c1*cfm(1,2)
+ cb1(n+1,mlb-1,L) = cfm(4,2)*(1.0+c1*LL1/ri(i)**2)
+ cb1(n+1,mlb,L) = -c1*cfm(2,2)
+ cb1(n+1,mlb+1,L) = cfm(5,2)*(1.0+c1*LL1/ri(i+1)**2)
+ cb1(n+1,mlb+2,L) = -c1*cfm(3,2)
+ cb2(n+1,mlb-2,L) = c1*cfm(1,2)
+ cb2(n+1,mlb-1,L) = cfm(4,2)*(1.0-c1*LL1/ri(i)**2)
+ cb2(n+1,mlb,L) = c1*cfm(2,2)
+ cb2(n+1,mlb+1,L) = cfm(5,2)*(1.0-c1*LL1/ri(i+1)**2)
+ cb2(n+1,mlb+2,L) = c1*cfm(3,2)
+ cj1(n,mlj-2,L) = cfm(1,2)
+ cj1(n,mlj,L) = cfm(2,2)
+ cj1(n,mlj+1,L) = -cfm(4,2)
+ cj1(n,mlj+2,L) = cfm(3,2)
+ cj1(n,mlj+3,L) = -cfm(5,2)
+ cj1(n+1,mlj-2,L) = -c1*cfm(1,2)
+ cj1(n+1,mlj-1,L) = cfm(4,2)*(1.0+c1*LL1/ri(i)**2)
+ cj1(n+1,mlj,L) = -c1*cfm(2,2)
+ cj1(n+1,mlj+1,L) = cfm(5,2)*(1.0+c1*LL1/ri(i+1)**2)
+ cj1(n+1,mlj+2,L) = -c1*cfm(3,2)
+ cj2(n+1,mlj-2,L) = c1*cfm(1,2)
+ cj2(n+1,mlj-1,L) = cfm(4,2)*(1.0-c1*LL1/ri(i)**2)
+ cj2(n+1,mlj,L) = c1*cfm(2,2)
+ cj2(n+1,mlj+1,L) = cfm(5,2)*(1.0-c1*LL1/ri(i+1)**2)
+ cj2(n+1,mlj+2,L) = c1*cfm(3,2)
+
+c----------------Matching conditions at the ICB
+
+ cb1(nmx4,mlb,L) = 1.0
+ cb1(nmx4,mlb+2,L)= -1.0
+ cj1(nmx4,mlj,L) = 1.0
+ cj1(nmx4,mlj+2,L)= -1.0
+
+ enddo
+
+ endif
+
+c (2) The matrix elements in the outer core
+
+c (2.1) Boundary conditions at the ICB
+
+ if (kicbb .eq. 0) then
+
+c-------------Perfectly insulating ICB
+
+ do L = 1,Lmax_m
+ cb1(nmbic+1,mlb+1,L)= -(L+1)/rio
+ cb1(nmbic+1,mlb+2,L)= 1.0
+ cj1(nmbic+1,mlj+1,L)= 1.0
+ enddo
+
+ else if (kicbb .eq. 1) then
+
+c-------------Perfectly conducting ICB
+
+ do L = 1,Lmax_m
+ cb1(nmbic+1,mlb+1,L)= 1.0
+ cj1(nmbic+1,mlb+2,L)= 1.0
+ enddo
+
+ else if (kicbb .eq. 2) then
+
+c-------------Matching conditions at the ICB
+
+ do L = 1,Lmax_m
+ cb1(nmbic+1,mlb,L) = -1.0
+ cb1(nmbic+1,mlb+2,L)= 1.0
+ cj1(nmbic+1,mlj,L) = -rmi*etaio
+ cj1(nmbic+1,mlj+2,L)= rmi
+ enddo
+
+ endif
+
+c (2.2) Matrix elements inside the outer core
+
+ do L = 1,Lmax_m
+
+ LL1 = LL(L)
+ c2 = ct*rmi*avismb(L)
+
+ do i = 0,1
+ n = nmbic+2*i+2
+ cb1(n,mlb,L) = cfm(1,3+i)
+ cb1(n,mlb+1,L) = -cfm(4,3+i)
+ cb1(n,mlb+2,L) = cfm(2,3+i)
+ cb1(n,mlb+3,L) = -cfm(5,3+i)
+ cb1(n,mlb+4,L) = cfm(3,3+i)
+ cb1(n+1,mlb-1,L)= cfm(4,3+i)*(1.0+c2*LL1/rr(i)**2)
+ cb1(n+1,mlb,L) = -c2*cfm(1,3+i)
+ cb1(n+1,mlb+1,L)= cfm(5,3+i)*(1.0+c2*LL1/rr(i+1)**2)
+ cb1(n+1,mlb+2,L)= -c2*cfm(2,3+i)
+ cb1(n+1,mlb+4,L)= -c2*cfm(3,3+i)
+ cb2(n+1,mlb-1,L)= cfm(4,3+i)*(1.0-c2*LL1/rr(i)**2)
+ cb2(n+1,mlb,L) = c2*cfm(1,3+i)
+ cb2(n+1,mlb+1,L)= cfm(5,3+i)*(1.0-c2*LL1/rr(i+1)**2)
+ cb2(n+1,mlb+2,L)= c2*cfm(2,3+i)
+ cb2(n+1,mlb+4,L)= c2*cfm(3,3+i)
+ cj1(n,mlj,L) = cfm(1,3+i)
+ cj1(n,mlj+1,L) = -cfm(4,3+i)
+ cj1(n,mlj+2,L) = cfm(2,3+i)
+ cj1(n,mlj+3,L) = -cfm(5,3+i)
+ cj1(n,mlj+4,L) = cfm(3,3+i)
+ cj1(n+1,mlj-1,L)= cfm(4,3+i)*(1.0+c2*LL1/rr(i)**2)
+ cj1(n+1,mlj,L) = -c2*cfm(1,3+i)
+ cj1(n+1,mlj+1,L)= cfm(5,3+i)*(1.0+c2*LL1/rr(i+1)**2)
+ cj1(n+1,mlj+2,L)= -c2*cfm(2,3+i)
+ cj1(n+1,mlj+4,L)= -c2*cfm(3,3+i)
+ cj2(n+1,mlj-1,L)= cfm(4,3+i)*(1.0-c2*LL1/rr(i)**2)
+ cj2(n+1,mlj,L) = c2*cfm(1,3+i)
+ cj2(n+1,mlj+1,L)= cfm(5,3+i)*(1.0-c2*LL1/rr(i+1)**2)
+ cj2(n+1,mlj+2,L)= c2*cfm(2,3+i)
+ cj2(n+1,mlj+4,L)= c2*cfm(3,3+i)
+ enddo
+ do i = 2,nmaxo-3
+ n = nmbic+2*i+2
+ cb1(n,mlb-2,L) = -hno/12.0
+ cb1(n,mlb,L) = -9.0*hno/12.0
+ cb1(n,mlb+1,L) = -0.5*gg(i)
+ cb1(n,mlb+2,L) = 9.0*hno/12.0
+ cb1(n,mlb+3,L) = -0.5*gg(i+1)
+ cb1(n,mlb+4,L) = hno/12.0
+ cb1(n+1,mlb-2,L)= c2*hno/12.0
+ cb1(n+1,mlb-1,L)= 0.5*gg(i)*(1.0+c2*LL1/rr(i)**2)
+ cb1(n+1,mlb,L) = 9.0*c2*hno/12.0
+ cb1(n+1,mlb+1,L)= 0.5*gg(i+1)*(1.0+c2*LL1/rr(i+1)**2)
+ cb1(n+1,mlb+2,L)= -9.0*c2*hno/12.0
+ cb1(n+1,mlb+4,L)= -c2*hno/12.0
+ cb2(n+1,mlb-2,L)= -c2*hno/12.0
+ cb2(n+1,mlb-1,L)= 0.5*gg(i)*(1.0-c2*LL1/rr(i)**2)
+ cb2(n+1,mlb,L) = -9.0*c2*hno/12.0
+ cb2(n+1,mlb+1,L)= 0.5*gg(i+1)*(1.0-c2*LL1/rr(i+1)**2)
+ cb2(n+1,mlb+2,L)= 9.0*c2*hno/12.0
+ cb2(n+1,mlb+4,L)= c2*hno/12.0
+ cj1(n,mlj-2,L) = -hno/12.0
+ cj1(n,mlj,L) = -9.0*hno/12.0
+ cj1(n,mlj+1,L) = -0.5*gg(i)
+ cj1(n,mlj+2,L) = 9.0*hno/12.0
+ cj1(n,mlj+3,L) = -0.5*gg(i+1)
+ cj1(n,mlj+4,L) = hno/12.0
+ cj1(n+1,mlj-2,L)= c2*hno/12.0
+ cj1(n+1,mlj-1,L)= 0.5*gg(i)*(1.0+c2*LL1/rr(i)**2)
+ cj1(n+1,mlj,L) = 9.0*c2*hno/12.0
+ cj1(n+1,mlj+1,L)= 0.5*gg(i+1)*(1.0+c2*LL1/rr(i+1)**2)
+ cj1(n+1,mlj+2,L)= -9.0*c2*hno/12.0
+ cj1(n+1,mlj+4,L)= -c2*hno/12.0
+ cj2(n+1,mlj-2,L)= -c2*hno/12.0
+ cj2(n+1,mlj-1,L)= 0.5*gg(i)*(1.0-c2*LL1/rr(i)**2)
+ cj2(n+1,mlj,L) = -9.0*c2*hno/12.0
+ cj2(n+1,mlj+1,L)= 0.5*gg(i+1)*(1.0-c2*LL1/rr(i+1)**2)
+ cj2(n+1,mlj+2,L)= 9.0*c2*hno/12.0
+ cj2(n+1,mlj+4,L)= c2*hno/12.0
+ enddo
+ i = nmaxo-2
+ n = nmbic+2*i+2
+ cb1(n,mlb,L) = cfm(1,5)
+ cb1(n,mlb+1,L) = -cfm(4,5)
+ cb1(n,mlb+2,L) = cfm(2,5)
+ cb1(n,mlb+3,L) = -cfm(5,5)
+ cb1(n,mlb+4,L) = cfm(3,5)
+ cb1(n+1,mlb-1,L)= cfm(4,5)*(1.0+c2*LL1/rr(i)**2)
+ cb1(n+1,mlb,L) = -c2*cfm(1,5)
+ cb1(n+1,mlb+1,L)= cfm(5,5)*(1.0+c2*LL1/rr(i+1)**2)
+ cb1(n+1,mlb+2,L)= -c2*cfm(2,5)
+ cb1(n+1,mlb+4,L)= -c2*cfm(3,5)
+ cb2(n+1,mlb-1,L)= cfm(4,5)*(1.0-c2*LL1/rr(i)**2)
+ cb2(n+1,mlb,L) = c2*cfm(1,5)
+ cb2(n+1,mlb+1,L)= cfm(5,5)*(1.0-c2*LL1/rr(i+1)**2)
+ cb2(n+1,mlb+2,L)= c2*cfm(2,5)
+ cb2(n+1,mlb+4,L)= c2*cfm(3,5)
+ cj1(n,mlj,L) = cfm(1,5)
+ cj1(n,mlj+1,L) = -cfm(4,5)
+ cj1(n,mlj+2,L) = cfm(2,5)
+ cj1(n,mlj+3,L) = -cfm(5,5)
+ cj1(n,mlj+4,L) = cfm(3,5)
+ cj1(n+1,mlj-1,L)= cfm(4,5)*(1.0+c2*LL1/rr(i)**2)
+ cj1(n+1,mlj,L) = -c2*cfm(1,5)
+ cj1(n+1,mlj+1,L)= cfm(5,5)*(1.0+c2*LL1/rr(i+1)**2)
+ cj1(n+1,mlj+2,L)= -c2*cfm(2,5)
+ cj1(n+1,mlj+4,L)= -c2*cfm(3,5)
+ cj2(n+1,mlj-1,L)= cfm(4,5)*(1.0-c2*LL1/rr(i)**2)
+ cj2(n+1,mlj,L) = c2*cfm(1,5)
+ cj2(n+1,mlj+1,L)= cfm(5,5)*(1.0-c2*LL1/rr(i+1)**2)
+ cj2(n+1,mlj+2,L)= c2*cfm(2,5)
+ cj2(n+1,mlj+4,L)= c2*cfm(3,5)
+ i = nmaxo-1
+ n = nmbic+2*i+2
+ cb1(n,mlb-2,L) = cfm(1,6)
+ cb1(n,mlb,L) = cfm(2,6)
+ cb1(n,mlb+1,L) = -cfm(4,6)
+ cb1(n,mlb+2,L) = cfm(3,6)
+ cb1(n,mlb+3,L) = -cfm(5,6)
+ cb1(n+1,mlb-2,L) = -c2*cfm(1,6)
+ cb1(n+1,mlb-1,L) = cfm(4,6)*(1.0+c2*LL1/rr(i)**2)
+ cb1(n+1,mlb,L) = -c2*cfm(2,6)
+ cb1(n+1,mlb+1,L) = cfm(5,6)*(1.0+c2*LL1/rr(i+1)**2)
+ cb1(n+1,mlb+2,L) = -c2*cfm(3,6)
+ cb2(n+1,mlb-2,L) = c2*cfm(1,6)
+ cb2(n+1,mlb-1,L) = cfm(4,6)*(1.0-c2*LL1/rr(i)**2)
+ cb2(n+1,mlb,L) = c2*cfm(2,6)
+ cb2(n+1,mlb+1,L) = cfm(5,6)*(1.0-c2*LL1/rr(i+1)**2)
+ cb2(n+1,mlb+2,L) = c2*cfm(3,6)
+ cj1(n,mlj-2,L) = cfm(1,6)
+ cj1(n,mlj,L) = cfm(2,6)
+ cj1(n,mlj+1,L) = -cfm(4,6)
+ cj1(n,mlj+2,L) = cfm(3,6)
+ cj1(n,mlj+3,L) = -cfm(5,6)
+ cj1(n+1,mlj-2,L) = -c2*cfm(1,6)
+ cj1(n+1,mlj-1,L) = cfm(4,6)*(1.0+c2*LL1/rr(i)**2)
+ cj1(n+1,mlj,L) = -c2*cfm(2,6)
+ cj1(n+1,mlj+1,L) = cfm(5,6)*(1.0+c2*LL1/rr(i+1)**2)
+ cj1(n+1,mlj+2,L) = -c2*cfm(3,6)
+ cj2(n+1,mlj-2,L) = c2*cfm(1,6)
+ cj2(n+1,mlj-1,L) = cfm(4,6)*(1.0-c2*LL1/rr(i)**2)
+ cj2(n+1,mlj,L) = c2*cfm(2,6)
+ cj2(n+1,mlj+1,L) = cfm(5,6)*(1.0-c2*LL1/rr(i+1)**2)
+ cj2(n+1,mlj+2,L) = c2*cfm(3,6)
+
+ enddo
+
+c (2.3) Boundary conditions at CMB
+
+ k = nmbic+nmx3
+
+ if (kcmbb .eq. 0) then
+
+c-------------Perfect insulating D"-layer
+
+ do L = 1,Lmax_m
+ cb1(k,mlb,L) = L
+ cb1(k,mlb+1,L)= 1.0
+ cj1(k,mlj,L) = 1.0
+ enddo
+
+ else if (kcmbb .eq. 1) then
+
+c-------------Perfect conducting D"-layer
+
+ do L = 1,Lmax_m
+ cb1(k,mlb,L) = 1.0
+ cj1(k,mlj+1,L)= 1.0
+ enddo
+
+ else if (kcmbb .eq. 2) then
+
+c-------------Finitely conducting D"-layer
+
+ do L = 1,Lmax_m
+ cb1(k,mlb,L) = 1.0
+ cb1(k,mlb+2,L)= -1.0
+ cj1(k,mlj+1,L)= rmi
+ cj1(k,mlj+3,L)= -rmi*etado
+ enddo
+
+ endif
+
+c (3) The matrix elements in the D"-layer
+
+ if (kcmbb .eq. 2) then
+
+ do L = 1,Lmax_m
+
+ LL1 = LL(L)
+ c3 = ct*rmi*etado
+c c3 = ct*rmi*etado*avismb(L)
+
+c----------------Matching conditions at the CMB
+
+ cb1(nmbic+nmx3+1,mlb,L) = -1.0
+ cb1(nmbic+nmx3+1,mlb+2,L)= 1.0
+ cj1(nmbic+nmx3+1,mlj-1,L)= -1.0
+ cj1(nmbic+nmx3+1,mlj+1,L)= 1.0
+
+c----------------Equations in the D" layer
+
+ do i = 0,1
+ n = nmbic+nmx3+2*i+2
+ cb1(n,mlb,L) = cfm(1,7+i)
+ cb1(n,mlb+1,L) = -cfm(4,7+i)
+ cb1(n,mlb+2,L) = cfm(2,7+i)
+ cb1(n,mlb+3,L) = -cfm(5,7+i)
+ cb1(n,mlb+4,L) = cfm(3,7+i)
+ cb1(n+1,mlb-1,L)= cfm(4,7+i)*(1.0+c3*LL1/rd(i)**2)
+ cb1(n+1,mlb,L) = -c3*cfm(1,7+i)
+ cb1(n+1,mlb+1,L)= cfm(5,7+i)*(1.0+c3*LL1/rd(i+1)**2)
+ cb1(n+1,mlb+2,L)= -c3*cfm(2,7+i)
+ cb1(n+1,mlb+4,L)= -c3*cfm(3,7+i)
+ cb2(n+1,mlb-1,L)= cfm(4,7+i)*(1.0-c3*LL1/rd(i)**2)
+ cb2(n+1,mlb,L) = c3*cfm(1,7+i)
+ cb2(n+1,mlb+1,L)= cfm(5,7+i)*(1.0-c3*LL1/rd(i+1)**2)
+ cb2(n+1,mlb+2,L)= c3*cfm(2,7+i)
+ cb2(n+1,mlb+4,L)= c3*cfm(3,7+i)
+ cj1(n,mlj,L) = cfm(1,7+i)
+ cj1(n,mlj+1,L) = -cfm(4,7+i)
+ cj1(n,mlj+2,L) = cfm(2,7+i)
+ cj1(n,mlj+3,L) = -cfm(5,7+i)
+ cj1(n,mlj+4,L) = cfm(3,7+i)
+ cj1(n+1,mlj-1,L)= cfm(4,7+i)*(1.0+c3*LL1/rd(i)**2)
+ cj1(n+1,mlj,L) = -c3*cfm(1,7+i)
+ cj1(n+1,mlj+1,L)= cfm(5,7+i)*(1.0+c3*LL1/rd(i+1)**2)
+ cj1(n+1,mlj+2,L)= -c3*cfm(2,7+i)
+ cj1(n+1,mlj+4,L)= -c3*cfm(3,7+i)
+ cj2(n+1,mlj-1,L)= cfm(4,7+i)*(1.0-c3*LL1/rd(i)**2)
+ cj2(n+1,mlj,L) = c3*cfm(1,7+i)
+ cj2(n+1,mlj+1,L)= cfm(5,7+i)*(1.0-c3*LL1/rd(i+1)**2)
+ cj2(n+1,mlj+2,L)= c3*cfm(2,7+i)
+ cj2(n+1,mlj+4,L)= c3*cfm(3,7+i)
+ enddo
+ do i = 2,nmaxm-2
+ n = nmbic+nmx3+2*i+2
+ cb1(n,mlb-2,L) = -hnm/12.0
+ cb1(n,mlb,L) = -9.0*hnm/12.0
+ cb1(n,mlb+1,L) = -0.5*gd(i)
+ cb1(n,mlb+2,L) = 9.0*hnm/12.0
+ cb1(n,mlb+3,L) = -0.5*gd(i+1)
+ cb1(n,mlb+4,L) = hnm/12.0
+ cb1(n+1,mlb-2,L)= c3*hnm/12.0
+ cb1(n+1,mlb-1,L)= 0.5*gd(i)*(1.0+c3*LL1/rd(i)**2)
+ cb1(n+1,mlb,L) = 9.0*c3*hnm/12.0
+ cb1(n+1,mlb+1,L)= 0.5*gd(i+1)*(1.0+c3*LL1/rd(i+1)**2)
+ cb1(n+1,mlb+2,L)= -9.0*c3*hnm/12.0
+ cb1(n+1,mlb+4,L)= -c3*hnm/12.0
+ cb2(n+1,mlb-2,L)= -c3*hnm/12.0
+ cb2(n+1,mlb-1,L)= 0.5*gd(i)*(1.0-c3*LL1/rd(i)**2)
+ cb2(n+1,mlb,L) = -9.0*c3*hnm/12.0
+ cb2(n+1,mlb+1,L)= 0.5*gd(i+1)*(1.0-c3*LL1/rd(i+1)**2)
+ cb2(n+1,mlb+2,L)= 9.0*c3*hnm/12.0
+ cb2(n+1,mlb+4,L)= c3*hnm/12.0
+ cj1(n,mlj-2,L) = -hnm/12.0
+ cj1(n,mlj,L) = -9.0*hnm/12.0
+ cj1(n,mlj+1,L) = -0.5*gd(i)
+ cj1(n,mlj+2,L) = 9.0*hnm/12.0
+ cj1(n,mlj+3,L) = -0.5*gd(i+1)
+ cj1(n,mlj+4,L) = hnm/12.0
+ cj1(n+1,mlj-2,L)= c3*hnm/12.0
+ cj1(n+1,mlj-1,L)= 0.5*gd(i)*(1.0+c3*LL1/rd(i)**2)
+ cj1(n+1,mlj,L) = 9.0*c3*hnm/12.0
+ cj1(n+1,mlj+1,L)= 0.5*gd(i+1)*(1.0+c3*LL1/rd(i+1)**2)
+ cj1(n+1,mlj+2,L)= -9.0*c3*hnm/12.0
+ cj1(n+1,mlj+4,L)= -c3*hnm/12.0
+ cj2(n+1,mlj-2,L)= -c3*hnm/12.0
+ cj2(n+1,mlj-1,L)= 0.5*gd(i)*(1.0-c3*LL1/rd(i)**2)
+ cj2(n+1,mlj,L) = -9.0*c3*hnm/12.0
+ cj2(n+1,mlj+1,L)= 0.5*gd(i+1)*(1.0-c3*LL1/rd(i+1)**2)
+ cj2(n+1,mlj+2,L)= 9.0*c3*hnm/12.0
+ cj2(n+1,mlj+4,L)= c3*hnm/12.0
+ enddo
+ i = nmaxm-1
+ n = nmbic+nmx3+2*i+2
+ cb1(n,mlb-2,L) = -0.5*hnm
+ cb1(n,mlb-1,L) = -gd(i-1)/6.0
+ cb1(n,mlb+1,L) = -2.0*gd(i)/3.0
+ cb1(n,mlb+2,L) = 0.5*hnm
+ cb1(n,mlb+3,L) = -gd(i+1)/6.0
+ cb1(n+1,mlb-3,L) = gd(i-1)*(1.0+c3*LL1/rd(i-1)**2)/6.0
+ cb1(n+1,mlb-2,L) = 0.5*c3*hnm
+ cb1(n+1,mlb-1,L) = 2.0*gd(i)*(1.0+c3*LL1/rd(i)**2)/3.0
+ cb1(n+1,mlb+1,L) = gd(i+1)*(1.0+c3*LL1/rd(i+1)**2)/6.0
+ cb1(n+1,mlb+2,L) = -0.5*c3*hnm
+ cb2(n+1,mlb-3,L) = gd(i-1)*(1.0-c3*LL1/rd(i-1)**2)/6.0
+ cb2(n+1,mlb-2,L) = -0.5*c3*hnm
+ cb2(n+1,mlb-1,L) = 2.0*gd(i)*(1.0-c3*LL1/rd(i)**2)/3.0
+ cb2(n+1,mlb+1,L) = gd(i+1)*(1.0-c3*LL1/rd(i+1)**2)/6.0
+ cb2(n+1,mlb+2,L) = 0.5*c3*hnm
+ cj1(n,mlj-2,L) = -0.5*hnm
+ cj1(n,mlj-1,L) = -gd(i-1)/6.0
+ cj1(n,mlj+1,L) = -2.0*gd(i)/3.0
+ cj1(n,mlj+2,L) = 0.5*hnm
+ cj1(n,mlj+3,L) = -gd(i+1)/6.0
+ cj1(n+1,mlj-3,L) = gd(i-1)*(1.0+c3*LL1/rd(i-1)**2)/6.0
+ cj1(n+1,mlj-2,L) = 0.5*c3*hnm
+ cj1(n+1,mlj-1,L) = 2.0*gd(i)*(1.0+c3*LL1/rd(i)**2)/3.0
+ cj1(n+1,mlj+1,L) = gd(i+1)*(1.0+c3*LL1/rd(i+1)**2)/6.0
+ cj1(n+1,mlj+2,L) = -0.5*c3*hnm
+ cj2(n+1,mlj-3,L) = gd(i-1)*(1.0-c3*LL1/rd(i-1)**2)/6.0
+ cj2(n+1,mlj-2,L) = -0.5*c3*hnm
+ cj2(n+1,mlj-1,L) = 2.0*gd(i)*(1.0-c3*LL1/rd(i)**2)/3.0
+ cj2(n+1,mlj+1,L) = gd(i+1)*(1.0-c3*LL1/rd(i+1)**2)/6.0
+ cj2(n+1,mlj+2,L) = 0.5*c3*hnm
+
+c----------------The boundary conditions at the perfectly insulating mantle
+
+ cb1(nmb,mlb,L) = L/rdo
+ cb1(nmb,mlb+1,L)= 1.0
+ cj1(nmb,mlj,L) = 1.0
+
+ enddo
+
+ endif
+
+
+C LU DECOMPOSITION OF (CB1,CB2)
+
+ do L = 1,Lmax_m
+ call zbandfa(cb1(1,1,L),nmb,nmx6,lb1,mlb,mub,
+ & ipvtb(1,L),info)
+ call zbandfa(cj1(1,1,L),nmb,nmx6,lj1,mlj,muj,
+ & ipvtj(1,L),info)
+ enddo
+
+ END SUBROUTINE BMATRIX
+
+*************************************************************************
+*************************************************************************
+
+ END MODULE mod_bmatrix
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+c
+c This module defines the matrices for the thermal equation
+c that solves the temperature perturbation;
+c
+c (CT1, CT2): the matrices for the temperature perturbation;
+c MLT: the # of diagonals below the main diagonal;
+c MUT: the # of diagonals above the main diagonal;
+c LT1 = 2*MLT+MUT+1;
+c LT2 = MLT+MUT+1;
+c IPVTT: the pivoting index for CT1;
+c
+c NMX3: the leading dimension of (CB, CJ);
+c
+c Author: Weijia Kuang
+c Date: Feb., 2001
+c COPY RIGHT: THIS CODE CAN NOT BE DUPLICATED OR USED WITHOUT
+c THE PERMISSION OF THE AUTHOR.
+c
+
+ MODULE mod_tmatrix
+
+ use mod_dimparam
+ use mod_sysparam
+ use mod_numparam
+ use mod_optparam
+
+ use mod_radgeom
+ use mod_sphgeom
+ use mod_artdis
+
+ implicit none
+
+ integer mlt,mut,lt1,lt2
+
+ integer, dimension(nmx3,0:Lmax_t) :: ipvtt
+
+ complex (kind=8) ct1(nmx3,10,0:Lmax_t),ct2(nmx3,7,0:Lmax_t)
+
+ CONTAINS
+
+c the subroutine that defines the matrices
+
+*************************************************************************
+*************************************************************************
+
+ SUBROUTINE tmatrix
+
+ implicit none
+
+ integer n,i,L,LL1,info
+ real (kind=8) c1,ctt,hn1,rmi,d1,d2
+
+C SUBROUTINE STARTS HERE
+
+ if (itrung .lt. 1) then
+ ctt = 0.25*deltt
+ else if (itrung .lt. 2) then
+ ctt = 0.375*deltt
+ else
+ ctt = 0.5*deltt
+ endif
+
+ hn1 = -nmaxo/pi
+ rmi = 1.0/rm
+
+ mlt = 3
+ mut = 3
+ lt1 = 2*mlt+mut+1
+ lt2 = mlt+mut+1
+
+ ct1 = 0.0
+ ct2 = 0.0
+
+C THE MATRIX ELEMENTS OF (CT1,CT2) IN THE OUTER CORE
+
+ do L = 0,Lmax_t
+
+ LL1 = LL(L)
+ c1 = ctt*rmi*qk*avismt(L)
+
+ do i = 0,1
+ n = 2*i+2
+ ct1(n,mlt,L) = cfm(1,3+i)
+ ct1(n,mlt+1,L) = -cfm(4,3+i)
+ ct1(n,mlt+2,L) = cfm(2,3+i)
+ ct1(n,mlt+3,L) = -cfm(5,3+i)
+ ct1(n,mlt+4,L) = cfm(3,3+i)
+ ct1(n+1,mlt-1,L)= cfm(4,3+i)*(1.0+c1*LL1/rr(i)**2)
+ ct1(n+1,mlt,L) = -c1*cfm(1,3+i)
+ ct1(n+1,mlt+1,L)= cfm(5,3+i)*(1.0+c1*LL1/rr(i+1)**2)
+ ct1(n+1,mlt+2,L)= -c1*cfm(2,3+i)
+ ct1(n+1,mlt+4,L)= -c1*cfm(3,3+i)
+ ct2(n+1,mlt-1,L)= cfm(4,3+i)*(1.0-c1*LL1/rr(i)**2)
+ ct2(n+1,mlt,L) = c1*cfm(1,3+i)
+ ct2(n+1,mlt+1,L)= cfm(5,3+i)*(1.0-c1*LL1/rr(i+1)**2)
+ ct2(n+1,mlt+2,L)= c1*cfm(2,3+i)
+ ct2(n+1,mlt+4,L)= c1*cfm(3,3+i)
+ enddo
+ do i = 2,nmaxo-3
+ n = 2*i+2
+ ct1(n,mlt-2,L) = -hn1/12.0
+ ct1(n,mlt,L) = -9.0*hn1/12.0
+ ct1(n,mlt+1,L) = -0.5*gg(i)
+ ct1(n,mlt+2,L) = 9.0*hn1/12.0
+ ct1(n,mlt+3,L) = -0.5*gg(i+1)
+ ct1(n,mlt+4,L) = hn1/12.0
+ ct1(n+1,mlt-2,L)= c1*hn1/12.0
+ ct1(n+1,mlt-1,L)= 0.5*gg(i)*(1.0+c1*LL1/rr(i)**2)
+ ct1(n+1,mlt,L) = 9.0*c1*hn1/12.0
+ ct1(n+1,mlt+1,L)= 0.5*gg(i+1)*(1.0+c1*LL1/rr(i+1)**2)
+ ct1(n+1,mlt+2,L)= -9.0*c1*hn1/12.0
+ ct1(n+1,mlt+4,L)= -c1*hn1/12.0
+ ct2(n+1,mlt-2,L)= -c1*hn1/12.0
+ ct2(n+1,mlt-1,L)= 0.5*gg(i)*(1.0-c1*LL1/rr(i)**2)
+ ct2(n+1,mlt,L) = -9.0*c1*hn1/12.0
+ ct2(n+1,mlt+1,L)= 0.5*gg(i+1)*(1.0-c1*LL1/rr(i+1)**2)
+ ct2(n+1,mlt+2,L)= 9.0*c1*hn1/12.0
+ ct2(n+1,mlt+4,L)= c1*hn1/12.0
+ enddo
+ i = nmaxo-2
+ n = 2*i+2
+ ct1(n,mlt,L) = cfm(1,5)
+ ct1(n,mlt+1,L) = -cfm(4,5)
+ ct1(n,mlt+2,L) = cfm(2,5)
+ ct1(n,mlt+3,L) = -cfm(5,5)
+ ct1(n,mlt+4,L) = cfm(3,5)
+ ct1(n+1,mlt-1,L)= cfm(4,5)*(1.0+c1*LL1/rr(i)**2)
+ ct1(n+1,mlt,L) = -c1*cfm(1,5)
+ ct1(n+1,mlt+1,L)= cfm(5,5)*(1.0+c1*LL1/rr(i+1)**2)
+ ct1(n+1,mlt+2,L)= -c1*cfm(2,5)
+ ct1(n+1,mlt+4,L)= -c1*cfm(3,5)
+ ct2(n+1,mlt-1,L)= cfm(4,5)*(1.0-c1*LL1/rr(i)**2)
+ ct2(n+1,mlt,L) = c1*cfm(1,5)
+ ct2(n+1,mlt+1,L)= cfm(5,5)*(1.0-c1*LL1/rr(i+1)**2)
+ ct2(n+1,mlt+2,L)= c1*cfm(2,5)
+ ct2(n+1,mlt+4,L)= c1*cfm(3,5)
+ i = nmaxo-1
+ n = 2*i+2
+ ct1(n,mlt-2,L) = cfm(1,6)
+ ct1(n,mlt,L) = cfm(2,6)
+ ct1(n,mlt+1,L) = -cfm(4,6)
+ ct1(n,mlt+2,L) = cfm(3,6)
+ ct1(n,mlt+3,L) = -cfm(5,6)
+ ct1(n+1,mlt-2,L) = -c1*cfm(1,6)
+ ct1(n+1,mlt-1,L) = cfm(4,6)*(1.0+c1*LL1/rr(i)**2)
+ ct1(n+1,mlt,L) = -c1*cfm(2,6)
+ ct1(n+1,mlt+1,L) = cfm(5,6)*(1.0+c1*LL1/rr(i+1)**2)
+ ct1(n+1,mlt+2,L) = -c1*cfm(3,6)
+ ct2(n+1,mlt-2,L) = c1*cfm(1,6)
+ ct2(n+1,mlt-1,L) = cfm(4,6)*(1.0-c1*LL1/rr(i)**2)
+ ct2(n+1,mlt,L) = c1*cfm(2,6)
+ ct2(n+1,mlt+1,L) = cfm(5,6)*(1.0-c1*LL1/rr(i+1)**2)
+ ct2(n+1,mlt+2,L) = c1*cfm(3,6)
+
+ enddo
+
+C THE MATRIX ELEMENTS OF (CT1,CT2) ON THE BOUNDARIES
+
+c The boundary conditions at the ICB
+
+ if (kicbt .eq. 0) then
+
+c-------------The fixed temperature conditions
+
+ do L = 0,Lmax_t
+ ct1(1,mlt+1,L) = 1.0
+ enddo
+
+ else if (kicbt .eq. 1) then
+
+c-------------The fixed heat flux conditions
+
+ do L = 0,Lmax_t
+ ct1(1,mlt+1,L) = -1.0/rio
+ ct1(1,mlt+2,L) = 1.0
+ enddo
+
+ endif
+
+c The boundary conditions at the CMB
+
+ if (kcmbt .eq. 0) then
+
+c-------------The fixed temperature conditions
+
+ do L = 0,Lmax_t
+ ct1(nmx3,mlt,L) = 1.0
+ enddo
+
+ else if (kcmbt .eq. 1) then
+
+c-------------The fixed heat flux conditions
+
+ do L = 0,Lmax_t
+ ct1(nmx3,mlt,L) = -1.0
+ ct1(nmx3,mlt+1,L) = 1.0
+ enddo
+
+ endif
+
+
+C LU DECOMPOSITION OF CT1
+
+
+ do L = 0,Lmax_t
+ call zbandfa(ct1(1,1,L),nmx3,nmx3,lt1,mlt,mut,
+ & ipvtt(1,L),info)
+ enddo
+
+
+ END SUBROUTINE tmatrix
+
+************************************************************************
+************************************************************************
+
+ END MODULE mod_tmatrix
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
Property changes on: geodyn/3D/MoSST/trunk/mod_matrices.f
___________________________________________________________________
Name: svn:executable
+
Added: geodyn/3D/MoSST/trunk/mod_params.f
===================================================================
--- geodyn/3D/MoSST/trunk/mod_params.f 2006-10-23 16:55:10 UTC (rev 5079)
+++ geodyn/3D/MoSST/trunk/mod_params.f 2006-10-23 20:50:23 UTC (rev 5080)
@@ -0,0 +1,273 @@
+ MODULE mod_dimparam
+!
+! This module defines the integers for various truncation orders
+! and the dimensions for physical solution vectors. The definitions
+! have included considerations of the dialiansing problems in spectral
+! transforms.
+!
+! Lmax_v: The order in colatitude expansion (L) for velocity;
+! mmax_v: The order in longitue expansion (m) for velocity;
+! Lmax_m: The order in colatitude expansion (L) for magnetic field;
+! mmax_m: The order in longitue expansion (m) for magnetic field;
+! Lmax_t: The order in colatitude expansion (L) for density anomaly;
+! mmax_t: The order in longitue expansion (m) for density anomaly;
+! Lmax: max(Lmax_v,Lmax_m,Lmax_t);
+! mmax: max(mmax_v,mmax_m,mmax_t);
+! nmaxo: The # of radial collocation points in the
+! outer core;
+! nmax_v: The order of Chebyshev expansion in velocity fields;
+! nmaxi: The # of radial collocation points in the
+! inner core;
+! nmaxm: The # of radial collocation points in the
+! D" layer;
+! miner: The longitudinal wave number for inertial force cut-off
+! m <= miner, inertia is included;
+! m > miner, inertia is ignored;
+! Lmaxa: the dimensions for spectral transforms;
+! mmaxa: the dimensions for spectral transforms;
+!
+! The suffix definitions are
+!
+! CDIA: dialiasing
+! CNDI: not-dialiasing
+! CANA: for data analysis
+!
+! Author: Weijia Kuang
+! Date: March, 2002
+! COPY RIGHT: THIS CODE CAN NOT BE DUPLICATED OR USED WITHOUT
+! THE PERMISSION OF THE AUTHOR.
+!
+
+ implicit none
+ integer Lmax_v,mmax_v,miner
+ integer Lmax_m,mmax_m
+ integer Lmax_t,mmax_t
+ integer Lmax,mmax
+ integer nmaxo,nmaxi,nmaxm,nmax_v
+ integer Lmax1,mmax1,nmxo1,nmxi1,nmxm1
+ integer nmx1,nmx2,nmx3,nmx4,nmx5,nmx6
+ integer Lmaxa,mmaxa,ntmax,npmax
+ parameter (Lmax_v=15,mmax_v=10,miner=1)
+ parameter (Lmax_m=15,mmax_m=10)
+ parameter (Lmax_t=15,mmax_t=10)
+ parameter (nmaxo=31,nmaxi=20,nmaxm=20)
+ parameter (Lmax=max0(Lmax_v,Lmax_m,Lmax_t))
+ parameter (mmax=max0(mmax_v,mmax_m,mmax_t))
+ parameter (Lmax1=Lmax+1,mmax1=mmax+1,nmxo1=nmaxo+1,
+ & nmxi1=nmaxi+1,nmxm1=nmaxm+1)
+ parameter (nmx1=nmxo1*(mmax_v-miner)*(2*Lmax_v+1-mmax_v-miner)/2,
+ & nmx2=nmxo1*(Lmax_v*miner+Lmax_v-miner*(miner-1)/2),
+ & nmx3=2*nmxo1,nmx4=2*nmxi1,nmx5=2*nmxm1,
+ & nmx6=nmx3+nmx4+nmx5)
+cdia parameter (Lmaxa=3*Lmax/2,mmaxa=3*mmax/2)
+cdia parameter (ntmax=3*Lmax/2+1,npmax=3*mmax+1)
+cdiv parameter (nmax_v=2*(nmaxo-1)/3)
+cndi parameter (Lmaxa=Lmax+4,mmaxa=mmax+4)
+cndi parameter (ntmax=Lmaxa+1,npmax=2*mmaxa+1)
+cndv parameter (nmax_v=nmaxo)
+cana parameter (Lmaxa=90,mmaxa=90)
+cana parameter (ntmax=Lmaxa+1,npmax=2*mmaxa+1)
+
+ END MODULE mod_dimparam
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ MODULE mod_numparam
+!
+! This module defines the parameters for numerical simulation
+! settings.
+!
+! NEVOL: the index for AB-AM algorithm or R-K method:
+! nevol = 0; (AB-AM)
+! nevol = 1; (R-K)
+! NCFL: the number of time steps for examining CFL condition
+! (NCFL >= 1);
+! NTT: the total number of time steps for simulation;
+! NINPUT: the index for the initial input data file;
+! NCOUNT: the index for the output data files;
+!
+! CFLMIN: the lower limit of CFL condition
+! cflmin = 0.8 (AB-AM)
+! cflmin = 1.4 (R-K)
+! CFLMAX: the upper limit of CFL condition
+! cflmax = 1.1; (AB-AM)
+! cflmax = 1.7; (R-K)
+! CFLNO: the CFL number;
+!
+! DELTT: time step;
+! TT0: starting simulation time;
+! TOUTF: time interval to output full numerical solutions;
+! TOUTD: time interval to output diagnostic results;
+!
+! VERSION: the versions of numerical simulation;
+!
+! Author: Weijia Kuang
+! Date: Jan., 2001
+! COPY RIGHT: THIS CODE CAN NOT BE DUPLICATED OR USED WITHOUT
+! THE PERMISSION OF THE AUTHOR.
+!
+ implicit none
+ integer ninput,ncount,ntt,ncfl,nevol
+ real (kind=8) cflmin,cflmax,cflno
+ real (kind=8) deltt,tt0,toutf,toutd
+ character version*6
+
+ END MODULE mod_numparam
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ MODULE mod_optparam
+
+!
+! This module defines the parameters for various options
+! applied to the model.
+!
+! KICBV: the parameter for the velocity boundary conditions
+! at the ICB:
+! kicbv = 0; (stress-free)
+! kicbv = 1; (no-slip)
+! kicbv = 2; (partial-slippery)
+! KCMBV: the parameter for the velocity boundary conditions
+! at the CMB:
+! kcmbv = 0; (stress-free)
+! kcmbv = 1; (no-slip)
+! kcmbv = 2; (slippery)
+! KCCBB: the parameter for the magnetic field boundary
+! conditions near the central core:
+! kccbb = 0; (perfectly insulationg central core)
+! kccbb = 1; (asymptotic cenral core)
+! KICBB: the parameter for the magnetic field boundary
+! conditions at the ICB:
+! kicbb = 0; (perfectly insulating)
+! kicbb = 1; (perfectly conducting)
+! kicbb = 2; (finitely conducting)
+! KCMBB: the parameter for the magnetic field boundary
+! conditions at the CMB:
+! kcmbb = 0; (perfectly insulating)
+! kcmbb = 1; (perfectly conducting)
+! kcmbb = 2; (finitely conducting)
+! KICBT: the parameter for the temperature field boundary
+! conditions at the ICB:
+! kicbt = 0; (fixed temperature)
+! kicbt = 1; (fixed heat flux)
+! KCMBT: the parameter for the temperature field boundary
+! conditions at the CMB:
+! kcmbt = 0; (fixed temperature)
+! kcmbt = 1; (fixed heat flux)
+! INDXT: the parameter to choose basic conductive state:
+! indxt = 0; conducting state with heat
+! fluxes at the boundaries;
+! indxt = 1; conducting state with uniform
+! heat sources in the outer core;
+!
+! K_ICROT: the index to approximate inner core rotation:
+! k_icrot = 0: no relative rotation between the
+! inner core and the mantle;
+! k_icrot = 1: only axial differential rotation of
+! of the inner core;
+! k_icrot = 2: full three-dimensional rotation of
+! the inner core
+!
+! ITRUNG: the parameter that decides the size of time steps
+! used in Runger-Kutter method;
+! itrung = 0; half time step Delt t/2;
+! itrung = 1; three-quater time step 3 Delt t/4;
+! itrung = 2; full time step Delt t;
+! ITUCMB: the iteration parameter for solving COU
+! (introduced with CMB heterogeneity);
+! ITVCMB: the iteration parameter for solving COV;
+! ITBCMB: the iteration parameter for solving COB;
+! ITJCMB: the iteration parameter for solving COJ;
+! ITTCMB: the iteration parameter for solving COT;
+!
+! Author: Weijia Kuang
+! Date: Jan., 2001
+! COPY RIGHT: THIS CODE CAN NOT BE DUPLICATED OR USED WITHOUT
+! THE PERMISSION OF THE AUTHOR.
+!
+
+ implicit none
+ integer kicbv,kcmbv
+ integer kccbb,kicbb,kcmbb
+ integer kicbt,kcmbt
+ integer k_icrot
+ integer indxt
+ integer itrung
+ integer itucmb,itvcmb,itbcmb,itjcmb,ittcmb
+
+ END MODULE mod_optparam
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ MODULE mod_sysparam
+!
+! This module defines the parameters of the physical system of the
+! model.
+!
+! RCC: the asymptotic limit in the center of the mantle;
+! RICB: the radius of the ICB;
+! RCMB: the radius of the CMB;
+! RDPP: the radius of the top of the D"-layer;
+! REAR: the radius of the Earth;
+!
+! RO: the Rossby number (for the linear fluid inertia);
+! RON: the Rossby number (for the nonlinear fluid inertia);
+! RM: the magnetic Renolds number (Default Rm = 1);
+! RATH: the thermal Rayleigh number;
+! QK: the (thermal) Prandtl number;
+! CM: the Elsasser number (Default CM = 1);
+! EKMAN: the Ekman number;
+!
+! RCO: the nondimentional RCC
+! RCO = RCC/RCMB;
+! RIO: the nondimentional RICB
+! RIO = RICB/RCMB;
+! RDO: the nondimentional RDPP
+! RDO = RDPP/RCMB;
+! REO: the nondimentional REAR
+! REO = REAR/RCMB;
+!
+! RHOOC: the mean density of the outer core;
+! RHOIO: the (nondimensional) density of the inner core
+! (relative to the outer core);
+! RHOMO: the (nondimensional) density of the mantle
+! (relative to the outer core);
+! MTI: the (nondimensional) moment of inertia of the inner core;
+! MTM: the (nondimensional) moment of inertia of the mantle;
+!
+! ETAIO: the magnetic diffusivity of the inner core relative
+! to the outer core;
+! ETADO: the magnetic diffusivity of the D" layer relative to
+! the outer core;
+!
+! ALPHT: the (nondimensional) internal heating within the outer
+! core relative to the mean heat flux at the ICB;
+! ALPHJ: the (nondimensional) Joul heating in the outer core;
+!
+! PI: pi;
+!
+! Author: Weijia Kuang
+! Date: June, 2002
+! COPY RIGHT: THIS CODE CAN NOT BE DUPLICATED OR USED WITHOUT
+! THE PERMISSION OF THE AUTHOR.
+!
+
+ implicit none
+ real (kind=8) pi
+ real (kind=8) ro,ron,rm,rath,cm,qk,ekman
+ real (kind=8) rcc,ricb,rcmb,rdpp,rear
+ real (kind=8) rco,rio,rdo,reo
+ real (kind=8) rhooc,rhoio,rhomo,mti,mtm
+ real (kind=8) etaio,etado
+ real (kind=8) alpht,alphj
+
+ END MODULE mod_sysparam
Property changes on: geodyn/3D/MoSST/trunk/mod_params.f
___________________________________________________________________
Name: svn:executable
+
Added: geodyn/3D/MoSST/trunk/mosst_cig.f
===================================================================
--- geodyn/3D/MoSST/trunk/mosst_cig.f 2006-10-23 16:55:10 UTC (rev 5079)
+++ geodyn/3D/MoSST/trunk/mosst_cig.f 2006-10-23 20:50:23 UTC (rev 5080)
@@ -0,0 +1,219 @@
+ program sphere
+*************************************************************************
+* *
+* This is a 3-D nonlinear numerical simulation of incompressible, *
+* conducting binary flow in a spherical shell system. The basic *
+* equations are momentum equation, induction equation, thermal *
+* equation and the equation governing the concentration of the *
+* lighter component. *
+* *
+* This is a 4th-order finite difference method program. *
+* *
+* W. Kuang 09/2002 *
+* *
+*-----------------------------------------------------------------------*
+* *
+* The flow fields (velocity, magnetic field, temperature and the *
+* concentration of the lighter component) are expanded in *
+* spherical harmonics on S-surface and chebyschev polynomials in *
+* radius: *
+* *
+* f(r_i) = \sum{|m|=0,M} \sum{l=|m|,L} f^{lm}(r_i) *
+* Y_l^m(theta,phi), (|m| <= L) *
+* r_i = a x_i + b, *
+* x_i = cos(al_i), *
+* a = [1-r_{io}]/2, *
+* b = [1+r_{io}]/2. *
+* *
+*-----------------------------------------------------------------------*
+* *
+* Detailed definition of quantities and parameters are given in *
+* the modules and in the subroutines where they first appear. *
+* *
+*-----------------------------------------------------------------------*
+* *
+* It should be compiled by "F90" on SUN workstation *
+* *
+*************************************************************************
+
+C
+C PROGRAM STARTS HERE
+C
+
+C
+C-------DETERMINE THE PARAMETERS, THE GEOMETRY AND THE INITIAL STATE
+c-------OF THE SYSTEM
+C
+
+ call datainput
+
+C
+C-------DETERMINE THE MATRICES FOR THE MOMENTUM EQUATION, THE INDUCTION
+C-------EQUATION AND THE THERMAL EQUATION
+C
+
+ call matrices
+
+C
+C-------EVALUATE THE TIME VARIATIONS OF THE FLOW
+C
+
+ call evolution
+
+ stop
+ end
+
+
+*************************************************************************
+*************************************************************************
+
+ subroutine datainput
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+c This subroutine provides the parameters of the system, the
+c geometry vectors and other conversion coefficients for
+c simulation
+c
+c Weijia Kuang, 09/2002
+c
+c------------------------------------------------------------------------
+c
+c In the outer core,
+c
+c r = a x + b;
+c r = rio at x = -1;
+c r = 1 at x = 1 .
+c
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ use mod_dimparam
+ use mod_sysparam
+ use mod_numparam
+ use mod_optparam
+
+ use mod_parity
+ use mod_radgeom
+ use mod_sphgeom
+ use mod_artdis
+
+ use mod_cmbheat
+
+ use mod_vfield
+ use mod_bfield
+ use mod_tfield
+ use mod_rotation
+
+ use mod_dataio
+
+ implicit none
+
+ integer i,L,m
+
+C
+C SUBROUTINE STARTS HERE
+C
+
+ call params_in
+
+ mti = 8.0*pi/15.0*rio**5
+ mtm = 8.0*pi/15.0*(reo**5-1.0)
+
+C CHECKING INPUT PARAMETERS
+
+ if (kicbv.gt.2 .or. kcmbv.gt.2) then
+ write(6,*) "inappropriate boundary conditions for velocity field!"
+ stop
+ endif
+ if (kccbb .gt. 1) then
+ write(6,*) "inappropriate boundary conditions for magnetic field!"
+ stop
+ endif
+ if (kicbb.gt.2 .or. kcmbb.gt.2) then
+ write(6,*) "inappropriate boundary conditions for magnetic field!"
+ stop
+ endif
+ if (nmaxi.eq.0 .and. kicbb.eq.2) then
+ write(6,*) "inappropriate conditions on the inner core!"
+ stop
+ endif
+ if (nmaxm.eq.0 .and. kcmbb.eq.2) then
+ write(6,*) "inappropriate conditions on the D-layer!"
+ stop
+ endif
+
+c Define the parity parameters for the model
+
+ call parity
+
+c Define the radial gridpoints, the Chebyshev polynomials and
+c the coefficients related to the radial gradients
+
+ call radgeom
+
+c Define the spherical collocation points and reccurence relation
+c coefficients; initialize spherical harmonic transforms
+
+ call sphgeom
+
+c Define the artificial dissipation
+
+ call artdis
+
+c Define the conducting temperature state
+
+ call cmbheat_basic
+
+c Define data I/O channels
+
+ call directname
+
+c Reading dynamo initial state
+
+ call data_in1
+
+! Optional input CMB topography profile if required
+
+! Optional input CMB heatflux anomaly profile if required
+
+! Optional input mantle density anomaly and the resultant gravity anomaly
+! coefficients at the CMB if required
+
+ return
+ end
+
+*************************************************************************
+*************************************************************************
+
+ subroutine evolution
+c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c +
+c This subroutine determines the CFLMIN and CFLMAX for given time +
+c evolution schemes. It also calls the corresponding subroutines +
+c for the time integration. +
+c +
+c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ use mod_dimparam
+ use mod_numparam
+
+ implicit none
+
+C
+C SUBROUTINE STARTS HERE
+C
+
+ if (nevol .lt. 1) then
+
+c----------AB/AM method
+
+ call evol_abam
+
+ else
+
+c----------R/K method
+
+ call evol_rk
+
+ endif
+
+ return
+ end
+
Property changes on: geodyn/3D/MoSST/trunk/mosst_cig.f
___________________________________________________________________
Name: svn:executable
+
Added: geodyn/3D/MoSST/trunk/parameter.data
===================================================================
--- geodyn/3D/MoSST/trunk/parameter.data 2006-10-23 16:55:10 UTC (rev 5079)
+++ geodyn/3D/MoSST/trunk/parameter.data 2006-10-23 20:50:23 UTC (rev 5080)
@@ -0,0 +1,68 @@
+ $phypar
+ rcc=120
+ ricb=1200
+ rcmb=3500
+ rdpp=3700
+ rear=6400
+ rhooc=10.0
+ rhoio=1.1
+ rhomo=0.4
+ etaio=1.0
+ etado=200.0
+ alpht=0.01
+ alphj=0.0
+ ro=2.e-5
+ ron=2.e-5
+ cm=1.0
+ ekman=2.e-5
+ rm=1.0
+ qk=1.0
+ rath=15000.0
+ kicbv=2
+ kcmbv=2
+ kccbb=1
+ kicbb=2
+ kcmbb=2
+ kicbt=1
+ kcmbt=1
+ itucmb=1
+ itvcmb=1
+ itbcmb=1
+ itjcmb=1
+ ittcmb=1
+ indxt=0
+ k_icrot=2
+ avisv1=0.05
+ avisv2=0.05
+ avisb=0.05
+ avist=0.05
+ navfb=2
+ navft=2
+ navfv1=0
+ navfv2=25
+ deltt=0.1e-05
+ tt0=0.0
+ toutf=0.001
+ toutd=0.0001
+ ntt=200000
+ nevol=0
+ ncfl=1
+ cflmin=0.8
+ cflmax=1.1
+ usr_name="kuang"
+ code_geom="sphere"
+ disc_in="sea10"
+ subdir_in="data"
+ version_in="fini01"
+ fileno_in=1000
+ disc_out="sea10"
+ subdir_out="data"
+ version_out="fini01"
+ fileno_out=1000
+ disc_diag="sea10"
+ subdir_diag="data"
+ version_diag="fini01"
+ disc_anom="sea10"
+ subdir_anom="data"
+ version_anom="anomaly_data"
+ $
Property changes on: geodyn/3D/MoSST/trunk/parameter.data
___________________________________________________________________
Name: svn:executable
+
Added: geodyn/3D/MoSST/trunk/params_io.f
===================================================================
--- geodyn/3D/MoSST/trunk/params_io.f 2006-10-23 16:55:10 UTC (rev 5079)
+++ geodyn/3D/MoSST/trunk/params_io.f 2006-10-23 20:50:23 UTC (rev 5080)
@@ -0,0 +1,380 @@
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ subroutine params_in
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+c This subroutine provides the parameters of the system, the
+c geometry vectors and other conversion coefficients for
+c simulation
+c
+c W. Kuang, 09/2002
+c
+c Additional parameters are added into the input list.
+c W. Kuang, 10/2003
+c
+c------------------------------------------------------------------------
+c
+c Input physical parameters are defined in the relevant modules.
+c
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ use mod_dimparam
+ use mod_sysparam
+ use mod_numparam
+ use mod_optparam
+
+ use mod_artdis
+ use mod_cmbheat
+
+ use mod_dataio
+
+ implicit none
+
+ integer i,L,m
+ real (kind=8) cvt,one
+
+C
+C SUBROUTINE STARTS HERE
+C
+
+C DATA INPUT STARTS HERE
+
+ namelist /phypar/rcc,ricb,rcmb,rdpp,rear,rhooc,rhoio,rhomo,
+ & etaio,etado,alpht,
+ & alphj,ro,ron,cm,ekman,rm,qk,rath,kicbv,kcmbv,kccbb,kicbb,
+ & kcmbb,kicbt,kcmbt,itucmb,itvcmb,itbcmb,itjcmb,ittcmb,indxt,
+ & k_icrot,avisv1,avisv2,avisb,
+ & avist,navfb,navft,navfv1,navfv2,deltt,tt0,toutf,toutd,ntt,
+ & nevol,ncfl,cflmin,cflmax,usr_name,code_geom,disc_in,
+ & subdir_in,version_in,fileno_in,disc_out,subdir_out,
+ & version_out,fileno_out,disc_diag,subdir_diag,
+ & version_diag,disc_anom,subdir_anom,version_anom
+
+ open(unit=10,file='parameter.data')
+
+ read(10,phypar)
+
+ close(10)
+
+C NONDIMENSIONAL PARAMETERS
+
+ one = 1.0
+ pi = 4.0*atan(one)
+
+ rco = rcc/rcmb
+ rio = ricb/rcmb
+ rdo = rdpp/rcmb
+ reo = rear/rcmb
+
+ return
+ end
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ subroutine output_files(unit_diag1,unit_diag2,unit_rec,unit_time)
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+! This subroutine defines the output files for diagnostic analysis
+! and records.
+!
+! Weijia Kuang: 10/2003
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ use mod_dataio
+
+ implicit none
+
+ character*50 record_indx,tmp_indx
+ character*200 file_rec,file_time
+ character*200 file_diag1,file_diag2
+
+ integer unit_diag1,unit_diag2,unit_rec,unit_time
+ integer i,j,length_rec,length_time,length_d1,length_d2
+
+!
+! Determine output file names
+!
+
+ call diagfilename
+
+ i = length_dout
+ if (i .eq. 0) then
+ call directname
+ i = length_dout
+ endif
+
+ file_diag1(1:length_diag) = file_diag(1:length_diag)
+ file_diag2(1:length_diag) = file_diag(1:length_diag)
+ length_d1 = length_diag
+ length_d2 = length_diag
+ file_diag1(length_d1+1:length_d1+9) = "field.out"
+ file_diag2(length_d2+1:length_d2+9) = "rotat.out"
+ length_d1 = length_d1+9
+ length_d2 = length_d2+9
+
+ file_time(1:i)= direct_out(1:i)
+ file_time(i+1:i+13) = "time_step.out"
+ length_time = i+13
+
+ file_rec(1:i) = direct_out(1:i)
+ file_rec(i+1:i+7) = "record."
+ i = i+7
+ write(tmp_indx,*) fileno_out
+ record_indx = adjustl(tmp_indx)
+ j = len_trim(record_indx)
+ file_rec(i+1:i+j) = record_indx(1:j)
+ length_rec = i+j
+
+!
+! Open output files
+!
+
+ unit_diag1 = 31
+ unit_diag2 = 32
+ unit_rec = 33
+ unit_time = 34
+ open(unit=unit_diag1,file=file_diag1(1:length_d1))
+ open(unit=unit_diag2,file=file_diag2(1:length_d2))
+ open(unit=unit_rec,file=file_rec(1:length_rec))
+ open(unit=unit_time,file=file_time(1:length_time))
+
+ return
+ end
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ subroutine diagout(unit_diag1,unit_diag2,tt,nd,i_diag)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+! This subroutine writes info into the diagnostic output file.
+!
+! unit_diag: the ouptu unit number of the diag file;
+! i_diag: the optional choice;
+! tt: the simulation time;
+!
+! Weijia Kuang: 10/2003
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ use mod_dimparam
+ use mod_sysparam
+ use mod_numparam
+ use mod_optparam
+
+ use mod_cmbheat
+
+ use mod_dataio
+
+ use mod_rotation
+
+ implicit none
+
+ integer unit_diag1,unit_diag2,i_diag,nd
+ real (kind=8) tt
+ real (kind=8) amv,amb,amt,elb,elv,elt
+
+!
+! Subroutine starts here
+
+
+ if (i_diag .eq. 0) then
+ write(unit_diag1,10) ro,ron,rm,cm,ekman,qk,alpht,alphj,
+ & rath,etaio,etado,Lmax_v,mmax_v,
+ & Lmax_m,mmax_m,Lmax_t,mmax_t,nmaxi,nmaxo,nmaxm,miner,
+ & nevol
+ write(unit_diag1,11)
+ write(unit_diag2,10) ro,ron,rm,cm,ekman,qk,alpht,alphj,
+ & rath,etaio,etado,Lmax_v,mmax_v,
+ & Lmax_m,mmax_m,Lmax_t,mmax_t,nmaxi,nmaxo,nmaxm,miner,
+ & nevol
+ write(unit_diag2,12)
+ endif
+
+ if (i_diag .eq. 1) then
+ call energy(amv,amb,amt,elv,elb,elt)
+ write(unit_diag1,13) tt,deltt,amv,amb,amt,elv,elb,elt,nd
+ write(unit_diag2,14) tt,deltt,omgih,omgiz,omgmh,omgmz,nd
+ call flush(unit_diag1)
+ call flush(unit_diag2)
+ endif
+
+ if (i_diag .eq. 2) then
+ call energy(amv,amb,amt,elv,elb,elt)
+ write(unit_diag1,13) tt,deltt,amv,amb,amt,elv,elb,elt,
+ & fileno_out
+ write(unit_diag2,14) tt,deltt,omgih,omgiz,omgmh,omgmz,
+ & fileno_out
+ call flush(unit_diag1)
+ call flush(unit_diag2)
+ endif
+
+ 10 format(1x,'R_o =',e11.4,2x,'R_on =',e11.4,2x,'R_m =',e11.4,
+ & 2x,'Lambda =',e11.4/1x,'Ekman =',e11.4,2x,'q_k =',e11.4,2x,
+ & 'alpht =',e11.4,2x,'alphj =',e11.4/1x,
+ & 'R_th =',e12.5,2x,'eta_io =',e12.5,2x,'eta_do =',e12.5/1x,
+ & 'L_v =',i3,1x,
+ & 'M_v =',i3,1x,'L_m =',i3,1x,'M_m =',i3,1x,'L_t =',i3,1x,
+ & 'M_t =',i3,1x,'N_i =',i3,2x,'N_o =',i3,2x,'N_d =',i3,2x,
+ & 'M_iner =',i3,2x,'N_evol =',i3)
+ 11 format(/7x,'T',12x,'D_T',11x,'E_v',11x,'E_b',11x,'E_T',11x,
+ & 'L_v',11x,'L_b',11x,'L_t',6x,'NF'/)
+ 12 format(/7x,'T',13x,'D_T',12x,'wix',12x,'wiy',12x,'wiz',12x,
+ & 'wmx',12x,'wmy',12x,'wmz',7x,'NF'/)
+
+ 13 format(8(1x,e13.7),1x,i4)
+ 14 format(8(1x,e14.8),1x,i4)
+
+ return
+ end
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ subroutine recout(unit_rec,i_rec)
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+! This subroutine writes the info into the record output file.
+!
+! unit_rec: the ouptu unit number of the record file;
+! i_rec: the optional choice;
+!
+! Weijia Kuang: 10/2003
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ use mod_dimparam
+ use mod_sysparam
+ use mod_numparam
+ use mod_optparam
+
+ use mod_radgeom
+ use mod_artdis
+
+ use mod_cmbheat
+
+ use mod_dataio
+
+ implicit none
+
+ integer unit_rec,i_rec
+
+ character*50 cdates
+ integer len_cdates
+
+!
+! Subroutine starts here
+!
+
+ call timing(cdates,len_cdates)
+
+ if (i_rec .eq. 0) then
+ write(unit_rec,10) cdates
+ write(unit_rec,11) Lmax_v,mmax_v,Lmax_m,mmax_m,Lmax_t,
+ & mmax_t,nmaxi,nmaxo,nmaxm,miner,ro,ron,rm,cm,ekman,
+ & qk,alpht,alphj,rath,etaio,etado,
+ & indxt,k_icrot,
+ & rhooc,rhoio,rhomo,rcc,ricb,rcmb,rdpp,rear,
+ & navfb,navft,navfv1,navfv2,nevol,avisv1,avisv2,avisb,
+ & avist,kicbv,kcmbv,kccbb,kicbb,kcmbb,kicbt,kcmbt,
+ & itucmb,itvcmb,itbcmb,itjcmb,ittcmb,toutf,toutd
+ endif
+
+ if (i_rec .eq. 1) then
+ write(unit_rec,12) fileno_out,cdates
+ call flush(unit_rec)
+ endif
+
+ 10 format(1x,'Date:',1x,a23)
+ 11 format(1x,'Parameters for the calculation'//1x,'L_v = ',i3,
+ & 1x,'M_v = ',i3,1x,'L_m =',i3,1x,'M_m =',i3,1x,'L_t =',i3,1x,
+ & 'M_t =',i3,1x,'N_i = ',i3,1x,'N_o = ',i3,1x,'N_m = ',i3,1x,
+ & 'M_iner =',i3/1x,'R_o =',e11.4,1x,'R_on =',e11.4,1x,'R_m =',
+ & e11.4,1x,'Lambda =',e11.4,1x,'E =',e11.4/1x,'q_k =',e11.4,
+ & 1x,'alpht =',e11.4,1x,'alphj =',e11.4,1x,'R_th =',e11.4/1x,
+ & 'eta_io =',e11.4,1x,'eta_do =',e11.4
+ & /1x,'eps_ht =',e11.4,1x,'indxt =',i2/1x,
+ & 'k_icrot =',i2,1x,'rho_oc =',e11.4,1x,
+ & 'rho_io =',e11.4,1x,'rho_mo =',e11.4/1x,
+ & 'rcc =',e11.4,1x,'ricb =',e11.4,1x,'rcmb =',e11.4,1x,
+ & 'rdpp =',e11.4,1x,'rear =',e11.4/1x,'N_avb =',i3,1x,
+ & 'N_avt =',i3,1x,'N_avv1 =',i3,1x,'N_avv2 =',i3,1x,
+ & 'N_evol =',i3/1x,'avisv1 =',e11.4,1x,'avisv2 =',e11.4,1x,
+ & 'avisb =',e11.4,1x,'avist =',e11.4/1x,'kicbv =',i2,1x,
+ & 'kcmbv =',i2,1x,'kccbb =',i2,1x,'kicbb =',i2,1x,'kcmbb =',i2,
+ & 1x,'kicbt =',i2,1x,'kcmbt =',i2/1x,'itucmb =',i2,1x,
+ & 'itvcmb =',i2,1x,'itbcmb =',i2,1x,'itjcmb =',i2,1x,'ittcmb =',
+ & i2/1x,'toutf =',e11.4,1x,'toutd =',e11.4/)
+ 12 format(1x,'nfile =',i4,2x,'Time :',1x,a23)
+
+ return
+ end
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ subroutine timeout(unit_time,tt)
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+! This subroutine writes the info into the time output file.
+!
+! unit_time: the output unit number of the time file;
+! tt: the simulation time;
+!
+! Weijia Kuang: 10/2003
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ use mod_dimparam
+ use mod_sysparam
+ use mod_numparam
+ use mod_optparam
+
+ implicit none
+
+ integer unit_time
+ real (kind=8) tt
+
+ write(unit_time,10) deltt,tt
+ call flush(unit_time)
+
+ 10 format('Delt t =',e12.5,2x,'T =',e12.5)
+
+ return
+ end
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ subroutine timing(dates,len_dates)
+
+ integer len_dates
+ character(*) dates
+ character*50 times
+ character*20 cdate1,cdate2,cdate3
+
+ call date_and_time(cdate1,cdate2,cdate3)
+ times(1:4) = cdate1(1:4)
+ times(5:5) = "/"
+ times(6:7) = cdate1(5:6)
+ times(8:8) = "/"
+ times(9:10)= cdate1(7:8)
+ times(11:11)= "/"
+ times(12:13)= cdate2(1:2)
+ times(14:14)= ":"
+ times(15:16)= cdate2(3:4)
+ times(17:17)= ":"
+ times(18:23)= cdate2(5:10)
+
+ len_dates = len_trim(times)
+ dates(1:len_dates) = times(1:len_dates)
+
+ return
+ end
Property changes on: geodyn/3D/MoSST/trunk/params_io.f
___________________________________________________________________
Name: svn:executable
+
Added: geodyn/3D/MoSST/trunk/readme
===================================================================
--- geodyn/3D/MoSST/trunk/readme 2006-10-23 16:55:10 UTC (rev 5079)
+++ geodyn/3D/MoSST/trunk/readme 2006-10-23 20:50:23 UTC (rev 5080)
@@ -0,0 +1,4 @@
+This directory holds all modules, subroutines and the main code of
+the MoSST for CIG.
+
+Weijia Kuang 10/2006
Property changes on: geodyn/3D/MoSST/trunk/readme
___________________________________________________________________
Name: svn:executable
+
Added: geodyn/3D/MoSST/trunk/solvers.f
===================================================================
--- geodyn/3D/MoSST/trunk/solvers.f 2006-10-23 16:55:10 UTC (rev 5079)
+++ geodyn/3D/MoSST/trunk/solvers.f 2006-10-23 20:50:23 UTC (rev 5080)
@@ -0,0 +1,290 @@
+c
+c This group of subroutines solve the linear equations of the
+c system. They are for Sun workstations with Sun Performance
+c Library.
+c W.Kuang: 08/99
+!
+! Last modified
+! W.Kuang: 03/2004
+c
+
+*************************************************************************
+*************************************************************************
+
+ subroutine solverv(fva,fvb)
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+c This subroutine solves (cova,covb) for given force (fva,fvb)
+c
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ use mod_dimparam
+ use mod_sysparam
+ use mod_optparam
+
+ use mod_parity
+
+ use mod_vfield
+
+ use mod_vmatrix
+
+ implicit none
+
+ complex (kind=8), dimension(nmx1) :: fva,fvb
+
+ integer i,k,L1,L2,k1,k2,L,m,nd_tp,n_st
+ complex (kind=8) bdvtp(0:Lmax_v,0:mmax_v,3)
+
+C
+C SUBROUTINE STARTS HERE
+C
+
+ cova = 0.0
+ covb = 0.0
+
+c-------solving (COVA,COVB) iteratively
+
+ do i = 1,itvcmb
+
+ cova = fva
+ covb = fvb
+
+ call zbandsl(cva,ndv,nmx1,lv,mlv,muv,ipvtva,cova)
+ call zbandsl(cvb,ndv,nmx1,lv,mlv,muv,ipvtvb,covb)
+
+ call group
+
+ enddo
+
+ return
+ end
+
+*************************************************************************
+*************************************************************************
+
+ subroutine solveru(coua1,coub1,fua,fub)
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+c This subroutine evaluates the inertia related flow (coua,coub)
+c for given forces.
+c
+c (FUA,FUB): the forcing terms
+c
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ use mod_dimparam
+ use mod_sysparam
+ use mod_optparam
+
+ use mod_parity
+
+ use mod_vfield
+ use mod_rotation
+
+ use mod_vmatrix
+
+ implicit none
+
+ complex (kind=8) bdvtp(0:Lmax_v,0:mmax_v,3)
+
+ integer i,k,L,L1,m,info
+ complex (kind=8) ui
+
+ complex (kind=8), dimension(nmx2) :: coua1,coub1,fua,fub
+
+C
+C SUBROUTINE STARTS HERE
+C
+
+ ui = cmplx(0.0,1.0)
+
+c (1) Updating boundary condtions
+
+ if (kicbv .eq. 1) then
+ fub(1)= sqrt(4.0*pi/3.0)*rio**2*omgiz
+ fub(kdm(0)+1)= -sqrt(2.0*pi/3.0)*rio**2*conjg(omgih)
+ endif
+ if (kicbv .eq. 2) then
+ fub(1)= -rio*rio*sqrt(4.0*pi/3.0)*omgiz
+ fub(kdm(0)+1)= rio*rio*(1.0-0.5*ui)*sqrt(2.0*pi/3.0)
+ & *conjg(omgih)
+ fub(nmxo1+2)= -rio*rio*sqrt(4.0*pi/5.0)*omgiz/3.0
+ fub(kdm(0)+nmxo1+2)= rio*rio*sqrt(pi/30.0)*conjg(omgih)
+ endif
+
+c-------Solving (COUA,COUB) iteratively
+
+ do i = 1,itucmb
+
+ coua = 0.0
+ coub = 0.0
+
+ coua = fua
+ coub = fub
+
+ coua = coua1+coua
+ coub = coub1+coub
+ call zbandsl(cua1,ndu,nmx2,lu1,mlu,muu,ipvtua,coua)
+ call zbandsl(cub1,ndu,nmx2,lu1,mlu,muu,ipvtub,coub)
+
+ call group
+
+ enddo
+
+ return
+ end
+
+
+*************************************************************************
+*************************************************************************
+
+ subroutine solverb(cob1,coj1,fb,fj)
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+c This subroutine solves (COB,COJ) for the given forces (FB,FJ)
+c
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ use mod_dimparam
+ use mod_sysparam
+ use mod_optparam
+
+ use mod_parity
+
+ use mod_bfield
+
+ use mod_bmatrix
+
+ implicit none
+
+ complex (kind=8), dimension(nmx6,Lmax_m,0:mmax_m) :: cob1,coj1,
+ & cob2,coj2
+ complex (kind=8), dimension(nmx6,0:Lmax_m,0:mmax_m) :: fb,fj
+ complex (kind=8), dimension(0:Lmax_m,0:mmax_m) :: bdbtp,bdjtp
+
+ integer i,k,L,m
+
+ complex (kind=8), dimension(0:Lmax_m,0:mmax_m) :: boundi,boundm
+
+C
+C SUBROUTINE STARTS HERE
+C
+
+c-------Solve COB iteratively
+
+ do i = 1,itbcmb
+
+ cob2 = 0.0
+ do L = 1,Lmax_m
+ do m = 0,lsym_m(L)
+ cob2(:,L,m) = fb(:,L,m)
+ enddo
+ enddo
+
+ do L = 1,Lmax_m
+ do m = 0,lsym_m(L)
+ cob(:,L,m) = cob1(:,L,m)+cob2(:,L,m)
+ call zbandsl(cb1(1,1,L),nmb,nmx6,lb1,mlb,
+ & mub,ipvtb(1,L),cob(1,L,m))
+ enddo
+ enddo
+
+ enddo
+
+
+c-------Solve COJ iteratively
+
+ do i = 1,itjcmb
+
+ coj2 = 0.0
+ do L = 1,Lmax_m
+ do m = 0,lsym_m(L)
+ coj2(:,L,m) = fj(:,L,m)
+ enddo
+ enddo
+
+ call bd_mag(boundi,boundm)
+
+ if (kicbb .eq. 2) then
+ k = nmbic+1
+ do L = 1,Lmax_m
+ coj2(k,L,0) = boundi(L,0)
+ enddo
+ do m = 1,mmax_m
+ do L = m,Lmax_m
+ coj2(k,L,m) = boundi(L,m)
+ enddo
+ enddo
+ endif
+ if (kcmbb .eq. 2) then
+ k = nmbic+nmx3
+ do L = 1,Lmax_m
+ coj2(k,L,0) = boundm(L,0)
+ enddo
+ do m = 1,mmax_m
+ do L = m,Lmax_m
+ coj2(k,L,m) = boundm(L,m)
+ enddo
+ enddo
+ endif
+
+ do L = 1,Lmax_m
+ do m = 0,lsym_m(L)
+ coj(:,L,m) = coj1(:,L,m)+coj2(:,L,m)
+ call zbandsl(cj1(1,1,L),nmb,nmx6,lj1,mlj,
+ & muj,ipvtj(1,L),coj(1,L,m))
+ enddo
+ enddo
+
+ enddo
+
+ return
+ end
+
+
+*************************************************************************
+*************************************************************************
+
+ subroutine solvert(cot1,ft)
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+c This subroutine evaluates the temperature COT for given force FT
+c
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ use mod_dimparam
+ use mod_sysparam
+ use mod_optparam
+
+ use mod_parity
+
+ use mod_tfield
+
+ use mod_tmatrix
+
+ implicit none
+
+ complex (kind=8), dimension(nmx3,0:Lmax_t,0:mmax_t) :: cot1,
+ & cot2,ft
+ complex (kind=8) bdttp(0:Lmax_t,0:mmax_t)
+
+ integer i,L,m
+
+C
+C SUBROUTINE STARTS HERE
+C
+
+ do i = 1,ittcmb
+
+ cot2 = 0.0
+ cot2 = ft
+
+ do L = 0,Lmax_t
+ do m = 0,lsym_t(L)
+ cot(:,L,m) = cot1(:,L,m)+cot2(:,L,m)
+ call zbandsl(ct1(1,1,L),nmx3,nmx3,lt1,mlt,
+ & mut,ipvtt(1,L),cot(1,L,m))
+ enddo
+ enddo
+
+ enddo
+
+ return
+ end
+
Property changes on: geodyn/3D/MoSST/trunk/solvers.f
___________________________________________________________________
Name: svn:executable
+
Added: geodyn/3D/MoSST/trunk/time_integ.f
===================================================================
--- geodyn/3D/MoSST/trunk/time_integ.f 2006-10-23 16:55:10 UTC (rev 5079)
+++ geodyn/3D/MoSST/trunk/time_integ.f 2006-10-23 20:50:23 UTC (rev 5080)
@@ -0,0 +1,1093 @@
+c
+c This group of subroutines provide time integration functions for
+c the dynamo modeling.
+c
+c Weijia Kuang: 10/2001
+c Weijia Kuang: 09/2002 (Last modified)
+c
+
+*************************************************************************
+*************************************************************************
+
+ subroutine abam3(gzi,gzim1,gzim2,gzm,gzmm1,gzmm2,ghi,ghim1,
+ & ghim2,ghm,ghmm1,ghmm2,fua,fuam1,fuam2,fub,fubm1,
+ & fubm2,fb,fbm1,fbm2,fj,fjm1,fjm2,ft,ftm1,ftm2,
+ & delt_g,drhomm,ndimg1,ndimg2,ndimg3,ndimg4)
+c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c +
+c This subroutine evaluates the time variation of the flow by the +
+c third order predictor(Adams-Bashord)-corrector(Adams-Molton) +
+c method. +
+c +
+c-----------------------------------------------------------------------+
+c +
+c Algorithem: +
+c +
+c d/dt L_1 f = L_2 f + N(f); +
+c +
+c A_1 y^[k+1] = A_2 f^[k] + dt/12 { 23 N(f^[k]) - +
+c 16 N(f^[k-1]) + 5 N(f^[k-2]) }; +
+c A_1 f^[k+1] = A_2 f^[k] + dt/12 { 5 N(y^[k+1]) + +
+c 8 N(f^[k]) - N(f^[k-1]) }; +
+c A_1 = L_1 - dt L_2/2; +
+c A_2 = L_1 + dt L_2/2; +
+c +
+c-----------------------------------------------------------------------+
+c +
+c Input: +
+c +
+c (GZI,GZIM1,GZIM2;GZM,GZMM1,GZMM2;GHI,GHIM1,GHIM2;GHM,GHMM1, +
+c GHMM2;FUA,FUAM1,FUAM2;FUB,FUBM1,FUBM2;FB,FBM1,FBM2;FJ,FJM1, +
+c FJM2;FT,FTM1,FTM2;FC,FCM1,FCM2): the nonlinear forcing at +
+c (t_k,t_[k-1],t_[k-2]); +
+c +
+c Results: +
+c +
+c (OMGI,OMGM,OMGHI,OMGHM,COUA,COUB,COB,COJ,COT,COC) +
+c updated for t = t_[k+1]. +
+c +
+c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ use mod_dimparam
+ use mod_sysparam
+ use mod_numparam
+ use mod_optparam
+
+ use mod_parity
+ use mod_radgeom
+
+ use mod_vfield
+ use mod_bfield
+ use mod_tfield
+ use mod_rotation
+
+ use mod_vmatrix
+ use mod_bmatrix
+ use mod_tmatrix
+
+ implicit none
+
+ integer ndimg1,ndimg2,ndimg3,ndimg4
+ real (kind=8) gzi,gzim1,gzim2,gzm,gzmm1,gzmm2
+ complex (kind=8) ghi,ghim1,ghim2,ghm,ghmm1,ghmm2
+
+ integer k,L,L1,m,n,i1,i2,i3,info
+ real (kind=8) ctt
+ real (kind=8) omgiz1,omgmz1,gzip,gzmp,gzi1,gzm1
+ real (kind=8) inert_iz,inert_mz
+ complex (kind=8) ui,uc1i,uc2i,uc1m,uc2m,uepss
+ complex (kind=8) omgih1,omgmh1,ghip,ghmp,ghi1,ghm1
+
+ real (kind=8) delt_g(ndimg1,ndimg2,0:ndimg3,3)
+ real (kind=8) drhomm(ndimg1,ndimg2,0:ndimg4,3)
+
+ complex (kind=8), dimension(nmx2) :: fua,fuam1,fuam2,fub,
+ & fubm1,fubm2,fuap,fubp,fua1,fub1,coua1,coub1
+
+ complex (kind=8), dimension(nmx6,0:Lmax_m,0:mmax_m) :: fb,fbm1,
+ & fbm2,fj,fjm1,fjm2,fbp,fjp,fb1,fj1
+ complex (kind=8), dimension(nmx6,Lmax_m,0:mmax_m) :: cob1,coj1
+
+ complex (kind=8), dimension(nmx3,0:Lmax_t,0:mmax_t) :: ft,ftm1,
+ & ftm2,ftp,ft1,cot1
+
+C
+C SUBROUTINE STARTS HERE
+C
+
+ ui = cmplx(0.0,1.0)
+ uepss = 0.0
+ ctt = deltt/12.0
+
+C
+C [0] Preparation for AB-AM method
+C
+
+c (0.1) Coefficients for the rotation rates
+
+ call linear_rot(inert_iz,inert_mz,uc1i,uc2i,uc1m,uc2m,deltt)
+
+c (0.2) The linear terms
+
+ omgmz1 = omgmz
+ omgmh1 = omgmh
+
+ if (k_icrot .lt. 1) then
+ omgiz1 = 0.0
+ omgih1 = 0.0
+ else if (k_icrot .lt. 2) then
+ omgiz1 = omgiz
+ omgih1 = 0.0
+ else
+ omgiz1 = omgiz
+ omgih1 = omgih
+ endif
+
+ call linear_term(coua1,coua,coub1,coub,cob1,cob,
+ & coj1,coj,cot1,cot)
+
+C
+C [1] The Adams-Bashford predictor
+C
+
+c (1.1) The nonlinear forcing terms
+
+! The modified torques for the solid body rotations of the
+! mantle and of the inner core
+
+ call torques_reform(gzi,ghi,gzm,ghm)
+
+! The Poincare term in the momentum equation defined in the
+! mantle reference frame
+
+ call poincare(fub,gzm,ghm)
+
+ gzi1 = ctt*(23.0*gzi-16.0*gzim1+5.0*gzim2)
+ gzm1 = ctt*(23.0*gzm-16.0*gzmm1+5.0*gzmm2)
+ ghi1 = ctt*(23.0*ghi-16.0*ghim1+5.0*ghim2)
+ ghm1 = ctt*(23.0*ghm-16.0*ghmm1+5.0*ghmm2)
+ fua1 = ctt*(23.0*fua-16.0*fuam1+5.0*fuam2)
+ fub1 = ctt*(23.0*fub-16.0*fubm1+5.0*fubm2)
+ ft1 = ctt*(23.0*ft-16.0*ftm1+5.0*ftm2)
+ fb1 = ctt*(23.0*fb-16.0*fbm1+5.0*fbm2)
+ fj1 = ctt*(23.0*fj-16.0*fjm1+5.0*fjm2)
+
+c (1.2) The predictor of the rotations
+
+ omgmz = omgmz1+gzm1/inert_mz
+ omgmh = (uc2m*omgmh1+ghm1)/uc1m
+
+ if (k_icrot .lt. 1) then
+ omgiz = 0.0
+ omgih = 0.0
+ else if (k_icrot .lt. 2) then
+ omgiz = omgiz1+gzi1/inert_iz
+ omgih = 0.0
+ else
+ omgiz = omgiz1+gzi1/inert_iz
+ omgih = (uc2i*omgih1+ghi1-uepss*(omgmh+omgmh1))/uc1i
+ endif
+
+c (1.3) The predictor of the other fields
+
+ call solveru(coua1,coub1,fua1,fub1)
+ call solvert(cot1,ft1)
+ call solverb(cob1,coj1,fb1,fj1)
+
+c (1.4) The nonlinear forcing for the corrector
+
+ call nonlinear(ndimg1,ndimg2,ndimg3,ndimg4,delt_g,drhomm,
+ & gzip,gzmp,ghip,ghmp,fuap,fubp,fbp,fjp,ftp)
+
+C
+C [2] The Adams-Molton corrector
+C
+
+c (2.1) The nonlinear forcing terms
+
+! The modified torques for the solid body rotations of the
+! mantle and of the inner core
+
+ call torques_reform(gzip,ghip,gzmp,ghmp)
+
+! The Poincare term in the momentum equation defined in the
+! mantle reference frame
+
+ call poincare(fubp,gzmp,ghmp)
+
+ gzi1 = ctt*(5.0*gzip+8.0*gzi-gzim1)
+ gzm1 = ctt*(5.0*gzmp+8.0*gzm-gzmm1)
+ ghi1 = ctt*(5.0*ghip+8.0*ghi-ghim1)
+ ghm1 = ctt*(5.0*ghmp+8.0*ghm-ghmm1)
+ fua1 = ctt*(5.0*fuap+8.0*fua-fuam1)
+ fub1 = ctt*(5.0*fubp+8.0*fub-fubm1)
+ ft1 = ctt*(5.0*ftp+8.0*ft-ftm1)
+ fb1 = ctt*(5.0*fbp+8.0*fb-fbm1)
+ fj1 = ctt*(5.0*fjp+8.0*fj-fjm1)
+
+c (2.2) Solving the rotation rates
+
+ omgmz = omgmz1+gzm1/inert_mz
+ omgmh = (uc2m*omgmh1+ghm1)/uc1m
+
+ if (k_icrot .lt. 1) then
+ omgiz = 0.0
+ omgih = 0.0
+ else if (k_icrot .lt. 2) then
+ omgiz = omgiz1+gzi1/inert_iz
+ omgih = 0.0
+ else
+ omgiz = omgiz1+gzi1/inert_iz
+ omgih = (uc2i*omgih1+ghi1-uepss*(omgmh+omgmh1))/uc1i
+ endif
+
+c (2.3) Solving the other fields
+
+ call solveru(coua1,coub1,fua1,fub1)
+ call solvert(cot1,ft1)
+ call solverb(cob1,coj1,fb1,fj1)
+
+ return
+ end
+
+
+*************************************************************************
+*************************************************************************
+
+ subroutine rungkt2(gzi1,gzm1,ghi1,ghm1,fua1,fub1,fb1,fj1,ft1,
+ & delt_g,drhomm,ndimg1,ndimg2,ndimg3,ndimg4)
+c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c +
+c This subroutine evaluates the time variation of the flow by a +
+c second order Runger-Kutter method. +
+c +
+c-----------------------------------------------------------------------+
+c +
+c Algorithem: +
+c +
+c d/dt L_1 f = L_2 f + N(f); +
+c +
+c A_1 y_1 = A_2 f^[k] + dt N(f^[k]); +
+c A_1 f^[k+1] = A_2 f^[k] + (dt/2) [N(f^[k]) + N(y_1)]; +
+c A_1 = L_1 - dt L_2/2; +
+c A_2 = L_1 + dt L_2/2; +
+c +
+c-----------------------------------------------------------------------+
+c +
+c Input: +
+c +
+c (GZI1,GZM1,GHI1,GHM1,FUA1,FUB1,FB1,FJ1,FT1,FC1): +
+c the forcing for first stage calculation at t_[k]; +
+c +
+c Results: +
+c +
+c (OMGIZ,OMGMZ,OMHI,OMHM,COUA,COUB,COB,COJ,COT,COC) +
+c updated to the new time. +
+c +
+c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ use mod_dimparam
+ use mod_sysparam
+ use mod_numparam
+ use mod_optparam
+
+ use mod_parity
+ use mod_radgeom
+
+ use mod_vfield
+ use mod_bfield
+ use mod_tfield
+ use mod_rotation
+
+ use mod_vmatrix
+ use mod_bmatrix
+ use mod_tmatrix
+
+ implicit none
+
+ integer ndimg1,ndimg2,ndimg3,ndimg4
+ real (kind=8) gzi1,gzm1
+ complex (kind=8) ghi1,ghm1
+
+ integer k,L,L1,m,n,i1,i2,i3,info
+ real (kind=8) aj,ctt
+ real (kind=8) omgiz1,omgmz1,gzi,gzm,gzi2,gzm2
+ real (kind=8) inert_iz,inert_mz
+ complex (kind=8) omgih1,omgmh1,ghi,ghm,ghi2,ghm2
+ complex (kind=8) ui,uc1i,uc2i,uc1m,uc2m,uepss
+
+ real (kind=8) delt_g(ndimg1,ndimg2,0:ndimg3,3)
+ real (kind=8) drhomm(ndimg1,ndimg2,0:ndimg4,3)
+
+ complex (kind=8), dimension(nmx2) :: fua1,fub1,fua2,fub2,
+ & fua,fub,coua1,coub1
+
+ complex (kind=8), dimension(nmx6,0:Lmax_m,0:mmax_m) :: fb1,fj1,
+ & fb2,fj2,fb,fj
+ complex (kind=8), dimension(nmx6,Lmax_m,0:mmax_m) :: cob1,coj1
+
+ complex (kind=8), dimension(nmx3,0:Lmax_t,0:mmax_t) :: ft1,ft2,
+ & ft,cot1
+
+C
+C SUBROUTINE STARTS HERE
+C
+
+ ui = cmplx(0.0,1.0)
+ uepss = 0.0
+
+ if (itrung .lt. 2) then
+ itrung = 2
+ call vmatrixu
+ call bmatrix
+ call tmatrix
+ endif
+
+C
+C [0] Preparation for the 2nd order R-K method
+C
+
+c (0.1) The coefficients for the rotation rates
+
+ call linear_rot(inert_iz,inert_mz,uc1i,uc2i,uc1m,uc2m,deltt)
+
+c (0.2) The linear terms
+
+ omgmz1 = omgmz
+ omgmh1 = omgmh
+
+ if (k_icrot .lt. 1) then
+ omgiz1 = 0.0
+ omgih1 = 0.0
+ else if (k_icrot .lt. 2) then
+ omgiz1 = omgiz
+ omgih1 = 0.0
+ else
+ omgiz1 = omgiz
+ omgih1 = omgih
+ endif
+
+ call linear_term(coua1,coua,coub1,coub,cob1,cob,
+ & coj1,coj,cot1,cot)
+
+C
+C [1] The first stage of the 2nd order R-K method
+C
+
+ ctt = deltt
+
+c (1.1) The nonlinear forcing terms
+
+! The modified torques for the solid body rotations of the
+! mantle and of the inner core
+
+ call torques_reform(gzi1,ghi1,gzm1,ghm1)
+
+! The Poincare term in the momentum equation defined in the
+! mantle reference frame
+
+ call poincare(fub1,gzm1,ghm1)
+
+ gzi = ctt*gzi1
+ gzm = ctt*gzm1
+ ghi = ctt*ghi1
+ ghm = ctt*ghm1
+ fua = ctt*fua1
+ fub = ctt*fub1
+ fb = ctt*fb1
+ fj = ctt*fj1
+ ft = ctt*ft1
+
+c (1.2) The predictor of the rotation rates
+
+ omgmz = omgmz1+gzm/inert_mz
+ omgmh = (uc2m*omgmh1+ghm)/uc1m
+
+ if (k_icrot .lt. 1) then
+ omgiz = 0.0
+ omgih = 0.0
+ else if (k_icrot .lt. 2) then
+ omgiz = omgiz1+gzi/inert_iz
+ omgih = 0.0
+ else
+ omgiz = omgiz1+gzi/inert_iz
+ omgih = (uc2i*omgih1+ghi-uepss*(omgmh+omgmh1))/uc1i
+ endif
+
+c (1.3) The predictor of the other fields
+
+ call solveru(coua1,coub1,fua,fub)
+ call solvert(cot1,ft)
+ call solverb(cob1,coj1,fb,fj)
+
+c (1.4) The nonlinear forcing for the 2nd stage
+
+ call nonlinear(ndimg1,ndimg2,ndimg3,ndimg4,delt_g,drhomm,
+ & gzi2,gzm2,ghi2,ghm2,fua2,fub2,fb2,fj2,ft2)
+
+C
+C [2] The second stage of the 2nd order R-K method
+C
+
+ ctt = 0.5*deltt
+
+c (2.1) The nonlinear forcing terms
+
+! The modified torques for the solid body rotations of the
+! mantle and of the inner core
+
+ call torques_reform(gzi2,ghi2,gzm2,ghm2)
+
+! The Poincare term in the momentum equation defined in the
+! mantle reference frame
+
+ call poincare(fub2,gzm2,ghm2)
+
+ gzi = ctt*(gzi1+gzi2)
+ gzm = ctt*(gzm1+gzm2)
+ ghi = ctt*(ghi1+ghi2)
+ ghm = ctt*(ghm1+ghm2)
+ fua = ctt*(fua1+fua2)
+ fub = ctt*(fub1+fub2)
+ fb = ctt*(fb1+fb2)
+ fj = ctt*(fj1+fj2)
+ ft = ctt*(ft1+ft2)
+
+c (2.2) Solving the rotation rates
+
+ omgmz = omgmz1+gzm/inert_mz
+ omgmh = (uc2m*omgmh1+ghm)/uc1m
+
+ if (k_icrot .lt. 1) then
+ omgiz = 0.0
+ omgih = 0.0
+ else if (k_icrot .lt. 2) then
+ omgiz = omgiz1+gzi/inert_iz
+ omgih = 0.0
+ else
+ omgiz = omgiz1+gzi/inert_iz
+ omgih = (uc2i*omgih1+ghi-uepss*(omgmh+omgmh1))/uc1i
+ endif
+
+c (2.3) Solving the other fields
+
+ call solveru(coua1,coub1,fua,fub)
+ call solvert(cot1,ft)
+ call solverb(cob1,coj1,fb,fj)
+
+ return
+ end
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ subroutine rungkt3(gzi1,gzm1,ghi1,ghm1,fua1,fub1,fb1,fj1,ft1,
+ & delt_g,drhomm,ndimg1,ndimg2,ndimg3,ndimg4)
+c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+c +
+c This subroutine evaluates the time variation of the flow by a +
+c third order Runger-Kutter method. +
+c +
+c-----------------------------------------------------------------------+
+c +
+c Algorithem: +
+c +
+c d/dt L_1 f = L_2 f + N(f); +
+c +
+c A_1a y_1 = A_2a f^[k] + (dt/2) N(f^[k]); +
+c A_1b y_2 = A_2b f^[k] + (3 dt/4) N(y_1); +
+c A_1 f^[k+1] = A_2 f^[k] + (dt/9) [2 N(f^[k]) + +
+c 3 N(y_1) + 4 N(y_2)]; +
+c A_1a = L_1 - dt L_2/4; +
+c A_1b = L_1 - 3 dt L_2/8; +
+c A_1 = L_1 - dt L_2/2; +
+c A_2a = L_1 + dt L_2/4; +
+c A_2b = L_1 + 3 dt L_2/8; +
+c A_2 = L_1 + dt L_2/2; +
+c +
+c-----------------------------------------------------------------------+
+c +
+c Input: +
+c +
+c (GZI1,GZM1,GHI1,GHM1,FUA1,FUB1,FB1,FJ1,FT1,FC1): +
+c the forcing for first stage calculation at t_[k]; +
+c +
+c Results: +
+c +
+c (OMGIZ,OMGMZ,OMHI,OMHM,COUA,COUB,COB,COJ,COT,COC) +
+c updated to the new time. +
+c +
+c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+ use mod_dimparam
+ use mod_sysparam
+ use mod_numparam
+ use mod_optparam
+
+ use mod_parity
+ use mod_radgeom
+
+ use mod_vfield
+ use mod_bfield
+ use mod_tfield
+ use mod_rotation
+
+ use mod_vmatrix
+ use mod_bmatrix
+ use mod_tmatrix
+
+ implicit none
+
+ integer ndimg1,ndimg2,ndimg3,ndimg4
+ real (kind=8) gzi1,gzm1
+ complex (kind=8) ghi1,ghm1
+
+ integer k,L,L1,m,n,i1,i2,i3,info
+ real (kind=8) aj,ctt
+ real (kind=8) omgiz1,omgmz1,gzi,gzm,gzi2,gzi3,gzm2,gzm3
+ real (kind=8) inert_iz,inert_mz
+ complex (kind=8) omgih1,omgmh1,ghi,ghm,ghi2,ghi3,ghm2,ghm3
+ complex (kind=8) ui,uepss
+ complex (kind=8) uc1i,uc1m,uc2i,uc2m
+
+ real (kind=8) delt_g(ndimg1,ndimg2,0:ndimg3,3)
+ real (kind=8) drhomm(ndimg1,ndimg2,0:ndimg4,3)
+
+ complex (kind=8), dimension(nmx2) :: fua1,fub1,fua2,fub2,
+ & fua3,fub3,fua,fub,coua1,coub1,coua0,coub0
+ complex (kind=8), dimension(nmx6,0:Lmax_m,0:mmax_m) :: fb1,fj1,
+ & fb2,fj2,fb3,fj3,fb,fj
+ complex (kind=8), dimension(nmx6,Lmax_m,0:mmax_m) :: cob1,coj1,
+ & cob0,coj0
+ complex (kind=8), dimension(nmx3,0:Lmax_t,0:mmax_t) :: ft1,ft2,
+ & ft3,ft,cot1,cot0
+
+C
+C SUBROUTINE STARTS HERE
+C
+
+ ui = cmplx(0.0,1.0)
+
+ omgmz1 = omgmz
+ omgmh1 = omgmh
+
+ if (k_icrot .lt. 1) then
+ omgiz1 = 0.0
+ omgih1 = 0.0
+ else if (k_icrot .lt. 2) then
+ omgiz1 = omgiz
+ omgih1 = 0.0
+ else
+ omgiz1 = omgiz
+ omgih1 = omgih
+ endif
+
+ coua0 = coua
+ coub0 = coub
+ cob0 = cob
+ coj0 = coj
+ cot0 = cot
+
+ if (itrung .gt. 0) then
+ itrung = 0
+ call vmatrixu
+ call bmatrix
+ call tmatrix
+ endif
+
+C
+C [1] The first stage of the 3rd order R-K method
+C
+
+ ctt = 0.5*deltt
+ uepss = 0.0
+
+c (1.2) The coefficients for the rotation rates
+
+ call linear_rot(inert_iz,inert_mz,uc1i,uc2i,uc1m,uc2m,ctt)
+
+c (1.3) The linear terms
+
+ call linear_term(coua1,coua0,coub1,coub0,cob1,cob0,
+ & coj1,coj0,cot1,cot0)
+
+c (1.4) The nonlinear forcing terms
+
+! The modified torques for the solid body rotations of the
+! mantle and of the inner core
+
+ call torques_reform(gzi1,ghi1,gzm1,ghm1)
+
+! The Poincare term in the momentum equation defined in the
+! mantle reference frame
+
+ call poincare(fub1,gzm1,ghm1)
+
+ gzi = ctt*gzi1
+ gzm = ctt*gzm1
+ ghi = ctt*ghi1
+ ghm = ctt*ghm1
+ fua = ctt*fua1
+ fub = ctt*fub1
+ fb = ctt*fb1
+ fj = ctt*fj1
+ ft = ctt*ft1
+
+c (1.5) The 1st predictor of the rotation rates
+
+ omgmz = omgmz1+gzm/inert_mz
+ omgmh = (uc2m*omgmh1+ghm)/uc1m
+
+ if (k_icrot .lt. 1) then
+ omgiz = 0.0
+ omgih = 0.0
+ else if (k_icrot .lt. 2) then
+ omgiz = omgiz1+gzi/inert_iz
+ omgih = 0.0
+ else
+ omgiz = omgiz1+gzi/inert_iz
+ omgih = (uc2i*omgih1+ghi-uepss*(omgmh+omgmh1))/uc1i
+ endif
+
+c (1.6) The 1st predictor of other fields
+
+ call solveru(coua1,coub1,fua,fub)
+ call solvert(cot1,ft)
+ call solverb(cob1,coj1,fb,fj)
+
+c (1.7) The nonlinear forcing for the 2nd stage
+
+ call nonlinear(ndimg1,ndimg2,ndimg3,ndimg4,delt_g,drhomm,
+ & gzi2,gzm2,ghi2,ghm2,fua2,fub2,fb2,fj2,ft2)
+
+C
+C [2] The second stage of the 3rd order R-K method
+C
+
+ ctt = 0.75*deltt
+ uepss = 0.0
+
+c (2.1) The matrices with the three-quater time step
+
+ itrung = 1
+ call vmatrixu
+ call bmatrix
+ call tmatrix
+
+c (2.2) The coefficients for the rotation rates
+
+ call linear_rot(inert_iz,inert_mz,uc1i,uc2i,uc1m,uc2m,ctt)
+
+c (2.3) The linear terms
+
+ call linear_term(coua1,coua0,coub1,coub0,cob1,cob0,
+ & coj1,coj0,cot1,cot0)
+
+c (2.4) The nonlinear forcing terms
+
+! The modified torques for the solid body rotations of the
+! mantle and of the inner core
+
+ call torques_reform(gzi2,ghi2,gzm2,ghm2)
+
+! The Poincare term in the momentum equation defined in the
+! mantle reference frame
+
+ call poincare(fub2,gzm2,ghm2)
+
+ gzi = ctt*gzi2
+ gzm = ctt*gzm2
+ ghi = ctt*ghi2
+ ghm = ctt*ghm2
+ fua = ctt*fua2
+ fub = ctt*fub2
+ fb = ctt*fb2
+ fj = ctt*fj2
+ ft = ctt*ft2
+
+c (2.5) The 2nd predictor of the rotation rates
+
+ omgmz = omgmz1+gzm/inert_mz
+ omgmh = (uc2m*omgmh1+ghm)/uc1m
+
+ if (k_icrot .lt. 1) then
+ omgiz = 0.0
+ omgih = 0.0
+ else if (k_icrot .lt. 2) then
+ omgiz = omgiz1+gzi/inert_iz
+ omgih = 0.0
+ else
+ omgiz = omgiz1+gzi/inert_iz
+ omgih = (uc2i*omgih1+ghi-uepss*(omgmh+omgmh1))/uc1i
+ endif
+
+c (2.6) The 2nd predictor of other fields
+
+ call solveru(coua1,coub1,fua,fub)
+ call solvert(cot1,ft)
+ call solverb(cob1,coj1,fb,fj)
+
+c (2.7) The nonlinear forcing for the 3rd stage
+
+ call nonlinear(ndimg1,ndimg2,ndimg3,ndimg4,delt_g,drhomm,
+ & gzi3,gzm3,ghi3,ghm3,fua3,fub3,fb3,fj3,ft3)
+
+C
+C [3] The third stage of the 3rd order R-K method
+C
+
+ ctt = deltt/9.0
+ uepss = 0.0
+
+c (3.1) The matrices with the full time step
+
+ itrung = 2
+ call vmatrixu
+ call bmatrix
+ call tmatrix
+
+c (3.2) The coefficients for the rotation rates
+
+ call linear_rot(inert_iz,inert_mz,uc1i,uc2i,uc1m,uc2m,deltt)
+
+c (3.3) The linear terms
+
+ call linear_term(coua1,coua0,coub1,coub0,cob1,cob0,
+ & coj1,coj0,cot1,cot0)
+
+c (3.4) The nonlinear forcing terms
+
+! The modified torques for the solid body rotations of the
+! mantle and of the inner core
+
+ call torques_reform(gzi3,ghi3,gzm3,ghm3)
+
+! The Poincare term in the momentum equation defined in the
+! mantle reference frame
+
+ call poincare(fub3,gzm3,ghm3)
+
+ gzi = ctt*(4.0*gzi3+3.0*gzi2+2.0*gzi1)
+ gzm = ctt*(4.0*gzm3+3.0*gzm2+2.0*gzm1)
+ ghi = ctt*(4.0*ghi3+3.0*ghi2+2.0*ghi1)
+ ghm = ctt*(4.0*ghm3+3.0*ghm2+2.0*ghm1)
+ fua = ctt*(4.0*fua3+3.0*fua2+2.0*fua1)
+ fub = ctt*(4.0*fub3+3.0*fub2+2.0*fub1)
+ fb = ctt*(4.0*fb3+3.0*fb2+2.0*fb1)
+ fj = ctt*(4.0*fj3+3.0*fj2+2.0*fj1)
+ ft = ctt*(4.0*ft3+3.0*ft2+2.0*ft1)
+
+c (3.5) Solve the rotation rates
+
+ omgmz = omgmz1+gzm/inert_mz
+ omgmh = (uc2m*omgmh1+ghm)/uc1m
+
+ if (k_icrot .lt. 1) then
+ omgiz = 0.0
+ omgih = 0.0
+ else if (k_icrot .lt. 2) then
+ omgiz = omgiz1+gzi/inert_iz
+ omgih = 0.0
+ else
+ omgiz = omgiz1+gzi/inert_iz
+ omgih = (uc2i*omgih1+ghi-uepss*(omgmh+omgmh1))/uc1i
+ endif
+
+c (3.6) Solving the other fields
+
+ call solveru(coua1,coub1,fua,fub)
+ call solvert(cot1,ft)
+ call solverb(cob1,coj1,fb,fj)
+
+ return
+ end
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ subroutine linear_term(coua1,coua0,coub1,coub0,cob1,cob0,
+ & coj1,coj0,cot1,cot0)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+! This subroutine evaluates the linear terms for the R-K method, or
+! AB-AM method.
+!
+!------------------------------------------------------------------------
+!
+! The inpput
+! (COUA0,COUB0,COB0,COJ0,COT0): the solution at given timestep;
+!
+! The outpput
+! (COUA1,COUB1,COB1,COJ1,COT1): the linear terms in R-K/AB-AM
+! methods;
+!
+! W. Kuang, 09/2002
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ use mod_dimparam
+ use mod_sysparam
+ use mod_numparam
+ use mod_optparam
+
+ use mod_parity
+ use mod_radgeom
+
+ use mod_vmatrix
+ use mod_bmatrix
+ use mod_tmatrix
+
+ implicit none
+
+ integer k,L,L1,m,n,i1,i2,i3
+
+ complex (kind=8), dimension(nmx2) :: coua1,coub1,coua0,coub0
+ complex (kind=8), dimension(nmx6,Lmax_m,0:mmax_m) :: cob1,coj1,
+ & cob0,coj0
+ complex (kind=8), dimension(nmx3,0:Lmax_t,0:mmax_t) :: cot1,cot0
+
+C
+C SUBROUTINE STARTS HERE
+C
+
+ cob1 = 0.0
+ coj1 = 0.0
+ cot1 = 0.0
+ coua1 = 0.0
+ coub1 = 0.0
+
+ do L = 1,Lmax_m
+ do m = 0,lsym_m(L)
+ do k = 1,mlb+mub+1
+ i1 = max0(1,mlb+2-k)
+ i2 = min0(nmb,mlb+1+nmb-k)
+ i3 = k-mlb-1
+ do n = i1,i2
+ cob1(n,L,m) = cob1(n,L,m)+cb2(n,k,L)*cob0(n+i3,L,m)
+ enddo
+ enddo
+ enddo
+ enddo
+
+ do L = 1,Lmax_m
+ do m = 0,lsym_m(L)
+ do k = 1,mlj+muj+1
+ i1 = max0(1,mlj+2-k)
+ i2 = min0(nmb,mlj+1+nmb-k)
+ i3 = k-mlj-1
+ do n = i1,i2
+ coj1(n,L,m) = coj1(n,L,m)+cj2(n,k,L)*coj0(n+i3,L,m)
+ enddo
+ enddo
+ enddo
+ enddo
+
+ do L = 0,Lmax_t
+ do m = 0,lsym_t(L)
+ do k = 1,mlt+mut+1
+ i1 = max0(1,mlt+2-k)
+ i2 = min0(nmx3,mlt+1+nmx3-k)
+ i3 = k-mlt-1
+ do n = i1,i2
+ cot1(n,L,m) = cot1(n,L,m)+ct2(n,k,L)*cot0(n+i3,L,m)
+ enddo
+ enddo
+ enddo
+ enddo
+
+ do k = 1,mlu+muu+1
+ i1= max0(1,mlu+2-k)
+ i2= min0(ndu,mlu+1+ndu-k)
+ i3= k-mlu-1
+ do n = i1,i2
+ coua1(n) = coua1(n)+cua2(n,k)*coua0(n+i3)
+ enddo
+ enddo
+
+ do k = 1,mlu+muu+1
+ i1= max0(1,mlu+2-k)
+ i2= min0(ndu,mlu+1+ndu-k)
+ i3= k-mlu-1
+ do n = i1,i2
+ coub1(n) = coub1(n)+cub2(n,k)*coub0(n+i3)
+ enddo
+ enddo
+
+ return
+ end
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ subroutine torques_reform(gzi,ghi,gzm,ghm)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+! This subroutine reforms the torques used to determine the solid
+! body rotation of the inner core and of the mantle.
+!
+!------------------------------------------------------------------------
+!
+! (GZI,GHI,GZM,GHM)
+! Input: the torques evaluated on the ICB and on the CMB.
+! Output: the torques for rotation variation.
+!
+! W. Kuang, 02/2004
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ use mod_dimparam
+ use mod_sysparam
+ use mod_numparam
+ use mod_optparam
+
+ use mod_rotation
+
+ implicit none
+
+ real (kind=8) gzi,gzm
+ complex (kind=8) ghi,ghm
+
+ real (kind=8) c1,c2
+ complex (kind=8) ui,z1,z2
+
+C
+C SUBROUTINE STARTS HERE
+C
+
+ ui = cmplx(0.0,1.0)
+
+ c1 = rhomo*mtm
+ c2 = rhoio*mti
+
+ if (k_icrot .lt. 1) then
+ gzm = (gzm+gzi)/(c1+c2)
+ ghm = (ghm+ghi)/(c2+c1)
+ gzi = 0.0
+ ghi = 0.0
+ else if (k_icrot .lt. 2) then
+ gzm = gzm/c1
+ ghm = (ghm+ghi+ui*ron*c2*omgiz*omgmh)/(c2+c1)
+ gzi = gzi/c2-gzm
+ ghi = 0.0
+ else
+ gzm = gzm/c1
+ ghm = ghm/c1
+ gzi = gzi/c2-ron*aimag(omgmh*conjg(omgih))-gzm
+ ghi = ghi/c2-ui*ron*(omgmz*omgih-omgmh*omgiz)-ghm
+ endif
+
+ return
+ end
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ subroutine linear_rot(inert_iz,inert_mz,uc1i,uc2i,uc1m,uc2m,ctt)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+! This subroutine evaluates the linear terms for the solid body
+! rotation of the inner core and of the mantle.
+!
+!------------------------------------------------------------------------
+!
+! The inpput
+! CTT: the time step in the time integration
+!
+! The outpput
+! (INERT_IZ,INERT_MZ,UC1I,UC2I,UC1M,UC2M): the linear terms in
+! R-K/AB-AM methods;
+!
+! W. Kuang, 02/2004
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ use mod_dimparam
+ use mod_sysparam
+ use mod_numparam
+ use mod_optparam
+
+ use mod_rotation
+
+ implicit none
+
+ real (kind=8) ctt,c1,c2
+ real (kind=8) inert_iz,inert_mz
+ complex (kind=8) ui,uc1i,uc2i,uc1m,uc2m
+
+C
+C SUBROUTINE STARTS HERE
+C
+
+ ui = cmplx(0.0,1.0)
+ c1 = rhomo*mtm
+ c2 = rhoio*mti
+
+ inert_iz = ro
+ inert_mz = ro
+ if (k_icrot .lt. 2) then
+ uc1i = ro
+ uc2i = ro
+ uc1m = ro
+ uc2m = ro
+ else
+ uc1i = ro+ui*0.25*ctt
+ uc2i = ro-ui*0.25*ctt
+ uc1m = ro
+ uc2m = ro
+ endif
+
+ return
+ end
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ subroutine poincare(fub,gzm,ghm)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+! This subroutine adds Poincare term into the momentum equation.
+!
+!------------------------------------------------------------------------
+!
+! The input
+! FUB: the nonlinear force for COUB.
+! (GZM,GHM): the torques for the mantle rotation variation.
+!
+! The outpput
+! FUB: the nonlinear force with the Poicare term added.
+!
+! W. Kuang, 02/2004
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ use mod_dimparam
+ use mod_sysparam
+ use mod_numparam
+ use mod_optparam
+
+ use mod_radgeom
+ use mod_parity
+ use mod_rotation
+
+ implicit none
+
+ real (kind=8) gzm
+ complex (kind=8) ghm,fub(nmx2)
+
+ integer i
+ complex (kind=8) c1,c2,ui
+
+!
+! SUBROUTINE STARTS HERE
+!
+
+ ui = cmplx(0.0,1.0)
+ c1 = sqrt(4.0*pi/3.0)*gzm
+
+ c2 = sqrt(2.0*pi/3.0)*conjg(ghm)
+
+!
+! (1) The Poincare term with d omgmz/dt
+!
+
+ do i = 1,nmaxo-1
+ fub(1+i) = fub(1+i)-rr(i)*rr(i)*c1
+ enddo
+
+!
+! (2) The Poincare term with d omgmh/dt
+!
+
+ if (miner .ge. 1) then
+ do i = 1,nmaxo-1
+ fub(kdm(0)+1+i) = fub(kdm(0)+1+i)+rr(i)*rr(i)*c2
+ enddo
+ endif
+
+ return
+ end
Property changes on: geodyn/3D/MoSST/trunk/time_integ.f
___________________________________________________________________
Name: svn:executable
+
More information about the cig-commits
mailing list