[cig-commits] r5121 - in geodyn/3D/MoSST/trunk: . lib src
wei at geodynamics.org
wei at geodynamics.org
Tue Oct 31 12:59:40 PST 2006
Author: wei
Date: 2006-10-31 12:59:39 -0800 (Tue, 31 Oct 2006)
New Revision: 5121
Added:
geodyn/3D/MoSST/trunk/lib/
geodyn/3D/MoSST/trunk/lib/aslegends.f
geodyn/3D/MoSST/trunk/lib/dbandfas.f
geodyn/3D/MoSST/trunk/lib/dbandsls.f
geodyn/3D/MoSST/trunk/lib/gaulegs.f
geodyn/3D/MoSST/trunk/lib/izfsphts.f
geodyn/3D/MoSST/trunk/lib/makefile
geodyn/3D/MoSST/trunk/lib/makefile1
geodyn/3D/MoSST/trunk/lib/readme
geodyn/3D/MoSST/trunk/lib/zbandfas.f
geodyn/3D/MoSST/trunk/lib/zbandsls.f
geodyn/3D/MoSST/trunk/lib/zfsphts.f
geodyn/3D/MoSST/trunk/src/
geodyn/3D/MoSST/trunk/src/bcs.f
geodyn/3D/MoSST/trunk/src/evolutions.f
geodyn/3D/MoSST/trunk/src/forces.f
geodyn/3D/MoSST/trunk/src/matrices.f
geodyn/3D/MoSST/trunk/src/miscs.f
geodyn/3D/MoSST/trunk/src/mod_anomaly.f
geodyn/3D/MoSST/trunk/src/mod_artdis.f
geodyn/3D/MoSST/trunk/src/mod_dataio.f
geodyn/3D/MoSST/trunk/src/mod_fields.f
geodyn/3D/MoSST/trunk/src/mod_matrices.f
geodyn/3D/MoSST/trunk/src/mod_params.f
geodyn/3D/MoSST/trunk/src/mosst_cig.f
geodyn/3D/MoSST/trunk/src/parameter.data
geodyn/3D/MoSST/trunk/src/params_io.f
geodyn/3D/MoSST/trunk/src/readme
geodyn/3D/MoSST/trunk/src/solvers.f
geodyn/3D/MoSST/trunk/src/time_integ.f
Removed:
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:
Added lib directory, moved original code to src directory.
Deleted: geodyn/3D/MoSST/trunk/bcs.f
===================================================================
--- geodyn/3D/MoSST/trunk/bcs.f 2006-10-30 23:07:45 UTC (rev 5120)
+++ geodyn/3D/MoSST/trunk/bcs.f 2006-10-31 20:59:39 UTC (rev 5121)
@@ -1,292 +0,0 @@
-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
-
-
Deleted: geodyn/3D/MoSST/trunk/evolutions.f
===================================================================
--- geodyn/3D/MoSST/trunk/evolutions.f 2006-10-30 23:07:45 UTC (rev 5120)
+++ geodyn/3D/MoSST/trunk/evolutions.f 2006-10-31 20:59:39 UTC (rev 5121)
@@ -1,907 +0,0 @@
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!
-! 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
-
Deleted: geodyn/3D/MoSST/trunk/forces.f
===================================================================
--- geodyn/3D/MoSST/trunk/forces.f 2006-10-30 23:07:45 UTC (rev 5120)
+++ geodyn/3D/MoSST/trunk/forces.f 2006-10-31 20:59:39 UTC (rev 5121)
@@ -1,1769 +0,0 @@
-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
-
Added: geodyn/3D/MoSST/trunk/lib/aslegends.f
===================================================================
--- geodyn/3D/MoSST/trunk/lib/aslegends.f 2006-10-30 23:07:45 UTC (rev 5120)
+++ geodyn/3D/MoSST/trunk/lib/aslegends.f 2006-10-31 20:59:39 UTC (rev 5121)
@@ -0,0 +1,144 @@
+ subroutine aslegend(p,z,Lmax,mmax,inorm)
+c************************************************************************
+c *
+c Evaluates normalized associated Legendre polynomial P(L,m) as *
+c function of *
+c *
+c z = cos(theta) *
+c *
+c up to L=LMAX, m=MMAX using recurrence relation starting with *
+c P(m,m) and then increasing L keeping m fixed. *
+c *
+c The normalization is: *
+c *
+c for INORM = 1, *
+c *
+c (Y(L,m)*,Y(L',m')) = 4 pi delta_{L L'} delta_{m m'}, *
+c *
+c for INORM = 2, *
+c *
+c (Y(L,m)*,Y(L',m')) = delta_{L L'} delta_{m m'}, *
+c *
+c where *
+c *
+c Y(L,m) = P(L,m) exp^{i*m*phi}, *
+c *
+c which is incorporated into the recurrence relation: *
+c *
+c P(L,m) = z P(L-1,m) \sqrt[(2L+1)(2L-1)/(L+m)(L-m)] - *
+c p(L-2,m) \sqrt[(2L+1)(L+m-1)(L-m-1)/(2L-3) *
+c (L+m)(L-m)]. *
+c *
+c In the subroutine, *
+c *
+c p(L,m) = P(L,m). *
+c *
+c Routine is modified from the Numerical Recp. subroutine. The *
+c method is stable in single and double precision to L,m = 511. *
+c W.Kuang, 17th, Aug. 1994. *
+c *
+c For the spherical transform developed by W.Kuang, orthonomal *
+c spherical harmonics (i.e. INORM=2) is necessary. *
+c *
+c This subroutine is for SUN workstations. *
+c *
+c************************************************************************
+ implicit none
+
+ integer inorm,L,Lmax,m,mmax
+ real (kind=8) fac,fden,fnum,f1,f2,pi,plm,pmm,pm1,pm2,
+ & sin2,z,one,sign
+ real (kind=8) p(0:Lmax,0:mmax)
+
+ one = 1.0
+ if (Lmax.lt.0 .or. mmax.gt.Lmax .or. abs(z).gt.one)
+ & pause 'bad arguments'
+
+ if (inorm.lt.0.5 .or. inorm.gt.2.5) then
+ write(6,99)
+ 99 format('inorm incorrect: '/
+ & ' inorm = 1 for Full normalisation'/
+ & ' inorm = 2 for orthonormal spherical harmonics')
+ stop
+ endif
+
+C Evaluating P(L,0) for L = 0,1,...,Lmax
+
+ pm2 = one
+ p(0,0) = one
+
+ if (Lmax .eq. 0) go to 25
+
+ pm1 = sqrt(3.0*one)*z
+ p(1,0) = pm1
+ do L = 2,Lmax
+ f1 = sqrt(one*(2*L+1)*(2*L-1))
+ f2 = (L-1)*sqrt(one*(2*L+1)/(one*(2*L-3)))
+ plm = (f1*z*pm1-f2*pm2)/L
+ p(L,0) = plm
+ pm2 = pm1
+ pm1 = plm
+ enddo
+
+ if (mmax .eq. 0) go to 25
+
+C Evaluating P(L,m) for m > 0
+
+ pmm = one
+ sin2 = (one-z)*(one+z)
+ fnum = one
+ fden = 0.0
+ sign = one
+
+ do m = 1,mmax
+
+C----------Evaluating P(m,m)
+
+ sign = -sign
+ fnum = fnum+2.0
+ fden = fden+2.0
+ pmm = pmm*sin2*fnum/fden
+ pm2 = sign*sqrt(pmm)
+ p(m,m) = pm2
+
+ if (m .eq. Lmax) goto 25
+
+C----------Evaluating P(m+1,m)
+
+ pm1 = z*pm2*sqrt(one*(2*m+3))
+ p(m+1,m)= pm1
+
+C----------Evaluating P(L,m) for L = m+2,...,Lmax
+
+ if (m .lt. (Lmax-1)) then
+ do L = m+2,Lmax
+ f1 = sqrt(one*(2*L+1)*(2*L-1)/(one*(L+m)
+ & *(L-m)))
+ f2 = sqrt(one*(2*L+1)*(L-m-1)*(L+m-1)/
+ & (one*(2*L-3)*(L+m)*(L-m)))
+ plm = z*f1*pm1-f2*pm2
+ p(L,m) = plm
+ pm2 = pm1
+ pm1 = plm
+ enddo
+ endif
+
+ enddo
+
+ 25 continue
+
+C Choice of normalization
+
+ if (inorm .eq. 2) then
+ pi = 4.0*atan(one)
+ fac = 1.0/sqrt(4.0*pi)
+ do m = 0,mmax
+ do L = m,Lmax
+ p(L,m) = p(L,m)*fac
+ enddo
+ enddo
+ endif
+
+ return
+ end
+
Added: geodyn/3D/MoSST/trunk/lib/dbandfas.f
===================================================================
--- geodyn/3D/MoSST/trunk/lib/dbandfas.f 2006-10-30 23:07:45 UTC (rev 5120)
+++ geodyn/3D/MoSST/trunk/lib/dbandfas.f 2006-10-31 20:59:39 UTC (rev 5121)
@@ -0,0 +1,113 @@
+
+ subroutine dbandfa(ua,n,nm,la,ml,mu,ipvt,info)
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+c This subroutine factors a double precision matrix UA
+c via partial pivoting:
+c P UA = L U.
+c
+c UA: the banded stored matrix of A;
+c A(i,j) = UA(i,j-i+ml+1).
+c ML: integer, # of diagonals below the main diagonal.
+c MU: integer, # of diagonals above the main diagonal.
+c LA: integer, LA = 2*ML + MU + 1.
+c NM: integer, the leading dimension of UA.
+c N: the rank of UA (N .le. NM).
+c IPVT: integer(N), the pivoting indices.
+c INFO: integer, condition number
+c = 0; nonsingular matrix.
+c = K; U(K,K) [UA(K,ML+1)] .eq. 0.d0.
+c
+c This subroutine is for SUN workstations and uses the SUN
+c Performance Library
+c W.Kuang 07/99
+c
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ implicit none
+
+ integer n,nm,la,ml,mu,info
+
+ integer ipvt(nm)
+ real (kind=8) ua(nm,la)
+
+ integer idamax
+ integer i,j,k,k1,k1t,k2t,k3t,k4t
+ integer ml1,lpu,n1,nm1,ma
+
+ real (kind=8) eps,ut
+
+ parameter (eps=1.e-12)
+
+c
+c Subroutine starts here
+c
+
+ ml1 = ml+1
+ lpu = ml+mu
+ n1 = n-1
+ nm1 = nm-1
+ ma = lpu+1
+ info = 0
+
+ if(n.le.1) go to 50
+C
+C set fill-in columns to zero
+C
+
+ do k = 1,ml
+ do i = 1,n
+ ua(i,ma+k)= 0.0
+ enddo
+ enddo
+
+C
+C LU decomposition with partial pivoting
+C
+
+ do k = 1,n1
+
+ k1t = min0(ml,n-k)
+ k2t = k1t+1
+ k3t = ml1-k1t
+
+c finding the maximum element in the column
+
+ k1 = k+k2t-idamax(k2t,ua(k1t+k,k3t),nm1)
+ ipvt(k)= k1
+ k4t = min0(lpu,n-k)
+
+c interchanging the rows if necessary
+
+ if(k1.ne.k) call dswap(k4t+1,ua(k,ml1),nm,ua(k1,ml1+k-k1),nm)
+
+c examine if the diagonal element is zero
+
+ if (abs(ua(k,ml1)) .le. eps) then
+ info = k
+ go to 20
+ endif
+
+c compute multipliers
+
+ ut = -1.0/ua(k,ml1)
+ call dscal(k1t,ut,ua(k1t+k,k3t),nm1)
+
+c raw elimination with column indexing
+
+ do j = 1,k4t
+ call daxpy(k1t,ua(k,ml1+j),ua(k1t+k,k3t),nm1,
+ * ua(k1t+k,k3t+j),nm1)
+ enddo
+
+ 20 continue
+
+ enddo
+
+ 50 continue
+
+ ipvt(n) = n
+ if (abs(ua(n,ml1)) .le. eps) info = n
+
+ return
+ end
+
Added: geodyn/3D/MoSST/trunk/lib/dbandsls.f
===================================================================
--- geodyn/3D/MoSST/trunk/lib/dbandsls.f 2006-10-30 23:07:45 UTC (rev 5120)
+++ geodyn/3D/MoSST/trunk/lib/dbandsls.f 2006-10-31 20:59:39 UTC (rev 5121)
@@ -0,0 +1,76 @@
+ subroutine dbandsls(ua,n,nm,la,ml,mu,ipvt,x)
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+c This subroutine is applied to solve a linear system
+c ua x = b
+c where
+c ua: the LU decomposed banded real matrix;
+c x: input: the inhomogeneous part;
+c output: the solution;
+c ipvt: the array for the pivoting indices;
+c nm: the dimension of ua;
+c n: the order of ua;
+c ml: the number of lower diagonals;
+c mu: the number of upper diagonals;
+c la = 2*ml + mu + 1;
+c
+c This subroutine is for SUN workstations and uses the Sun
+c Performance Library.
+c W.Kuang 07/99
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ implicit none
+
+ integer n,nm,la,ml,mu
+
+ integer ipvt(nm)
+ real (kind=8) ua(nm,la),x(nm)
+
+ integer i,j,k,k1,k1t,k2t
+ integer lpu,lpu1,ml1,n1,nm1
+
+ real (kind=8) ut
+
+c
+c subroutine starts here
+c
+
+ lpu = ml+mu
+ lpu1 = lpu+1
+ ml1 = ml+1
+ n1 = n-1
+ nm1 = 1-nm
+
+ if(ml.eq.0) go to 30
+ if(n1.lt.1) go to 30
+
+C------ solving L y = x
+
+ do k = 1,n1
+ k1t = min0(ml,n-k)
+ k1 = ipvt(k)
+ ut = x(k1)
+ if (k1 .ne. k) then
+ x(k1)= x(k)
+ x(k) = ut
+ endif
+ k2t = ml1-k1t
+ call daxpy(k1t,ut,ua(k+k1t,k2t),nm1,x(k+1),1)
+ enddo
+
+ 30 continue
+
+C------ solving U x = y
+
+ do i = 1,n
+ k = n-i+1
+ x(k) = x(k)/ua(k,ml1)
+ ut = -x(k)
+ k1t = min0(k,lpu1)-1
+ k2t = k-k1t
+ call daxpy(k1t,ut,ua(k-1,ml+2),nm1,x(k2t),1)
+ enddo
+
+ return
+ end
+
Added: geodyn/3D/MoSST/trunk/lib/gaulegs.f
===================================================================
--- geodyn/3D/MoSST/trunk/lib/gaulegs.f 2006-10-30 23:07:45 UTC (rev 5120)
+++ geodyn/3D/MoSST/trunk/lib/gaulegs.f 2006-10-31 20:59:39 UTC (rev 5121)
@@ -0,0 +1,82 @@
+ subroutine gauleg(x1,x2,root,wt,L)
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+c This subroutine calculates the assembly points in the colatitude
+c and the corresponding Gaussian weights on the points. It is
+c modified from NUM.RECP. subroutines. W.Kuang 15/08/94
+c
+c------------------------------------------------------------------------
+c
+c The assembly points ROOT(L) are the L zeros of the Legendre
+c polynomial P_L(x) [x = cos(th)]. They are symmetric about
+c (x1+x2)/2 and are obtained via Newton method. The Gaussian
+c weight WT(L) at the assembly points are defined as
+c
+c WT(i) = 2/(1-x_i^2)[P'_L(x_i)]^2.
+c
+c------------------------------------------------------------------------
+c
+c For the assembly points in the colatitude TH (in stead of x), see
+c GAULEG1.
+c
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ implicit none
+
+ integer L,i,j,m
+ real (kind=8) x1,x2,eps,pi,p1,p2,p3,pp,xl,xm,z,z1,one
+ real (kind=8), dimension(L) :: root,wt
+
+ parameter (eps=1.e-15)
+
+C
+C SUBROUTINE STARTS HERE
+C
+
+ one = 1.0
+ m = (L+1)/2
+ xm = 0.5*(x2+x1)
+ xl = 0.5*(x2-x1)
+ pi = 4.0*atan(one)
+
+ do i = 1,m
+
+c----------initial guess of Z_i
+
+ z = cos(pi*(i-0.25)/(L+0.5))
+
+c----------Employing Newton method to obtain Z_i
+
+ 1 continue
+
+ p1 = 1.0
+ p2 = 0.0
+ do j = 1,L
+ p3= p2
+ p2= p1
+ p1= ((2.0*j-1.0)*z*p2-(j-1.0)*p3)/(1.0*j)
+ enddo
+
+c----------Obtaining the derivative P_L'(z) by the values of
+c----------P_L(z) (p1) and P_[L-1] (p2).
+
+ pp = L*(z*p1-p2)/(z*z-1.0)
+ z1 = z
+ z = z1-p1/pp
+ if (dabs(z-z1) .gt. eps) goto 1
+
+ root(i) = xm-xl*z
+ root(L+1-i) = xm+xl*z
+ wt(i) = 2.0*xl/((1.0-z*z)*pp*pp)
+ wt(L+1-i) = wt(i)
+
+ enddo
+
+ z1 = sqrt(2.0*pi)
+
+ do i = 1,L
+ wt(i)= z1*wt(i)
+ enddo
+
+ return
+ end
+
Added: geodyn/3D/MoSST/trunk/lib/izfsphts.f
===================================================================
--- geodyn/3D/MoSST/trunk/lib/izfsphts.f 2006-10-30 23:07:45 UTC (rev 5120)
+++ geodyn/3D/MoSST/trunk/lib/izfsphts.f 2006-10-31 20:59:39 UTC (rev 5121)
@@ -0,0 +1,74 @@
+ subroutine izfspht(flm,p,wfftr,Lmax,mmax,ntmax,npmax,f)
+cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+c This is the complex-to-real inverse spherical transform: version 4.
+c For Linux PC with ABSOFT IMSL Library.
+c Weijia Kuang, 10/2002
+c
+c--------------------------------------------------------------------------
+c
+c The subroutine calculates
+c f(ph_i,th_j) = \sum{l,m} f_l^m Y_l^m(th_j,ph_i)
+c Y_l^m(th,ph) = P_l^m(th) exp(i m ph)
+c
+c--------------------------------------------------------------------------
+c
+c before this subroutine must call:
+c GAULEG: providing assembly points in colatitude
+c and the Gaussian weights;
+c ASLEGEND: providing the values of P_l^m at the assembly
+c points;
+c DFFTRI: initializing the array WFFTR for the FFT.
+c
+c--------------------------------------------------------------------------
+c
+c flm(l,m): input, complex spectral coefficients of F;
+c p(l,m,j): input, the values of P_l^m at the assembly points;
+c f(i,j): output, real values of F in the physical space (at
+c assembly points).
+c wfftr: 1--forward, 2--backward plan for fftw
+c Lmax: maximum degree in colatitude;
+c mmax: maximum degree in longitude;
+c ntmax: # of assembly points in colatitude; (ntmax >= 2*mmax+1)
+c npmax: # of assembly points in longitude; (npmax >= 2*Lmax+1)
+c
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ implicit none
+
+ integer Lmax,mmax,ntmax,npmax
+
+ real (kind=8) p(0:Lmax,0:mmax,ntmax),f(npmax,ntmax),ft(npmax)
+! real (kind=8) wfftr(4*npmax+30) ! for absoft IMSL table
+ integer (kind=8) wfftr(2)
+ complex (kind=8) flm(0:Lmax,0:mmax)
+ complex (kind=8) temp(0:mmax)
+ integer i,k,L,m
+
+ complex (kind=8) c1
+
+
+C
+C SUBROUTINE STARTS HERE
+C
+
+ f = 0.0
+ do k = 1,ntmax
+ temp(0)=(0.0,0.0)
+ c1 = 0.0
+ do L = 0,Lmax
+ c1 = c1+p(L,0,k)*flm(L,0)
+ enddo
+ temp(0) = cmplx(real(c1),0.0)
+ do m = 1,mmax
+ c1= 0.0
+ do L = m,Lmax
+ c1= c1+p(L,m,k)*flm(L,m)
+ enddo
+! ft(2*m) = real(c1)
+! ft(2*m+1) = aimag(c1)
+ temp(m)=c1
+ enddo
+! call df2trb(npmax,ft,f(1,k),wfftr)
+ call dfftw_execute_dft_c2r(wfftr(2),temp,f(1,k))
+ enddo
+ end
Added: geodyn/3D/MoSST/trunk/lib/makefile
===================================================================
--- geodyn/3D/MoSST/trunk/lib/makefile 2006-10-30 23:07:45 UTC (rev 5120)
+++ geodyn/3D/MoSST/trunk/lib/makefile 2006-10-31 20:59:39 UTC (rev 5121)
@@ -0,0 +1,7 @@
+LIBDIR=$HOME/lib
+LIB=intelsub90d
+
+ifort -static -r8 -nofor_main -c *.f -L/opt/fftw3.0.1/lib -lfftw3 -L/usr/lib -lblas
+ar -cru $LIBDIR/lib$LIB.a *.o
+rm -f *.o
+rm -f *.out
Added: geodyn/3D/MoSST/trunk/lib/makefile1
===================================================================
--- geodyn/3D/MoSST/trunk/lib/makefile1 2006-10-30 23:07:45 UTC (rev 5120)
+++ geodyn/3D/MoSST/trunk/lib/makefile1 2006-10-31 20:59:39 UTC (rev 5121)
@@ -0,0 +1,7 @@
+LIBDIR=$HOME/lib
+LIB=sub90
+
+f90 *.f -xlic_lib=sunperf -xlibmopt -lmvec -fast -c
+ar -ru $LIBDIR/lib$LIB.a *.o
+rm -f *.o
+rm -f *.out
Added: geodyn/3D/MoSST/trunk/lib/readme
===================================================================
--- geodyn/3D/MoSST/trunk/lib/readme 2006-10-30 23:07:45 UTC (rev 5120)
+++ geodyn/3D/MoSST/trunk/lib/readme 2006-10-31 20:59:39 UTC (rev 5121)
@@ -0,0 +1,7 @@
+In this library collection, all FFT routines are called from
+Linux_based, ABSOFT IMSL library.
+Weijia Kuang, 10/2002
+
+In this version, FFTW replaces FFT in IMSL.
+
+Weiyuan Jiang, 08/2004
Added: geodyn/3D/MoSST/trunk/lib/zbandfas.f
===================================================================
--- geodyn/3D/MoSST/trunk/lib/zbandfas.f 2006-10-30 23:07:45 UTC (rev 5120)
+++ geodyn/3D/MoSST/trunk/lib/zbandfas.f 2006-10-31 20:59:39 UTC (rev 5121)
@@ -0,0 +1,103 @@
+ subroutine zbandfa(ua,n,nm,la,ml,mu,ipvt,info)
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+c This is the complex version of "dbandfa" to LU decompose a
+c banded complex UA via partial pivoting.
+c
+c This subroutine is for SUN workstations and uses the
+c Sun Performance Library.
+c W.Kuang 07/99
+c
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+ implicit none
+
+ integer n,nm,la,ml,mu,info
+
+ integer ipvt(nm)
+ complex (kind=8) ua(nm,la)
+
+ integer izamax
+ integer i,j,k
+ integer k1,k1t,k2t,k3t,k4t,ml1,lpu,n1,nm1,ma
+
+ real (kind=8) eps
+ parameter (eps=1.e-12)
+
+ complex (kind=8) ut
+
+c
+c subroutine starts here
+c
+
+ ml1 = ml+1
+ lpu = ml+mu
+ n1 = n-1
+ nm1 = nm-1
+ ma = lpu+1
+ info = 0
+
+ if (n .le. 1) go to 50
+
+C
+C set fill-in columns to zero
+C
+
+ do k = 1,ml
+ do i = 1,n
+ ua(i,ma+k)= 0.0
+ enddo
+ enddo
+
+C
+C LU decomposition with partial pivoting
+C
+
+ do k = 1,n1
+
+ k1t = min0(ml,n-k)
+ k2t = k1t+1
+ k3t = ml1-k1t
+
+c finding the maximum element in the column
+
+ k1 = k+k2t-izamax(k2t,ua(k1t+k,k3t),nm1)
+ ipvt(k)= k1
+ k4t = min0(lpu,n-k)
+
+c interchanging the rows if necessary
+
+ if (k1 .ne. k) then
+ call zswap(k4t+1,ua(k,ml1),nm,ua(k1,ml1+k-k1),nm)
+ endif
+
+c examine if the diagonal element is zero
+
+ if (abs(ua(k,ml1)) .le. eps) then
+ info = k
+ go to 20
+ endif
+
+c calculating A(j,k) (j=k+1:n)
+
+ ut = -1.0/ua(k,ml1)
+ call zscal(k1t,ut,ua(k1t+k,k3t),nm1)
+
+c calculating A(k+1:n,k+1:n)
+
+ do j = 1,k4t
+ call zaxpy(k1t,ua(k,ml1+j),ua(k1t+k,k3t),nm1,
+ & ua(k1t+k,k3t+j),nm1)
+ enddo
+
+ 20 continue
+
+ enddo
+
+ 50 continue
+
+ ipvt(n) = n
+ if (abs(ua(n,ml1)) .le. eps) info = n
+
+ return
+ end
Added: geodyn/3D/MoSST/trunk/lib/zbandsls.f
===================================================================
--- geodyn/3D/MoSST/trunk/lib/zbandsls.f 2006-10-30 23:07:45 UTC (rev 5120)
+++ geodyn/3D/MoSST/trunk/lib/zbandsls.f 2006-10-31 20:59:39 UTC (rev 5121)
@@ -0,0 +1,69 @@
+ subroutine zbandsl(ua,n,nm,la,ml,mu,ipvt,x)
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+c This is the complex version of dbandsl to solve the linear
+c system
+c UA x = b
+c with the LU-decomposed UA.
+c
+c This subroutine is used for SUN workstations and uses the Sun
+c Performance Library.
+c W.Kuang 07/99
+c
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+
+ implicit none
+
+ integer n,nm,la,ml,mu
+ integer ipvt(nm)
+
+ complex (kind=8) ua(nm,la),x(nm)
+
+ integer i,j,k,k1,k1t,k2t
+ integer lpu,lpu1,ml1,n1,nm1
+
+ complex (kind=8) ut
+
+c
+c subroutine starts here
+c
+
+ lpu = ml+mu
+ lpu1 = lpu+1
+ ml1 = ml+1
+ n1 = n-1
+ nm1 = 1-nm
+
+ if (ml .eq. 0) go to 30
+ if (n1 .lt. 1) go to 30
+
+C------ solving L y = x
+
+ do k = 1,n1
+ k1t = min0(ml,n-k)
+ k1 = ipvt(k)
+ ut = x(k1)
+ if (k1 .ne. k) then
+ x(k1)= x(k)
+ x(k) = ut
+ endif
+ k2t = ml1-k1t
+ call zaxpy(k1t,ut,ua(k+k1t,k2t),nm1,x(k+1),1)
+ enddo
+
+ 30 continue
+
+C------ solving U x = y
+
+ do i = 1,n
+ k = n-i+1
+ x(k) = x(k)/ua(k,ml1)
+ ut = -x(k)
+ k1t = max0(1,k-lpu)
+ do j = k1t,k-1
+ x(j) = x(j)+ut*ua(j,k-j+ml1)
+ enddo
+ enddo
+
+ return
+ end
Added: geodyn/3D/MoSST/trunk/lib/zfsphts.f
===================================================================
--- geodyn/3D/MoSST/trunk/lib/zfsphts.f 2006-10-30 23:07:45 UTC (rev 5120)
+++ geodyn/3D/MoSST/trunk/lib/zfsphts.f 2006-10-31 20:59:39 UTC (rev 5121)
@@ -0,0 +1,75 @@
+ subroutine zfspht(f,p,gauwt,wfftr,Lmax,mmax,ntmax,npmax,flm)
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+c
+c This is the real-to-complex spherical transform: version 4.
+c For Linux PC with ABSOFT IMSL Library.
+c Weijia Kuang, 10/2002
+c
+c--------------------------------------------------------------------------
+c
+c before this subroutine must call:
+c GAULEG: providing assembly points in colatitude
+c and the Gaussian weights;
+c ASLEGEND: providing the values of P_l^m at the assembly
+c points;
+c DFFTRI: initializing the array WFFTR for the FFT.
+c
+c--------------------------------------------------------------------------
+c
+c f(i,j): input, real values of F in the physical space (at the
+c assembly points);
+c p(l,m,j): input, the values of P_l^m at the assembly points;
+c gauwt(j): input, the Gaussian weights in colatitude;
+c flm(l,m): output, complex spectral coefficients of F.
+c wfftr: 1--forward, 2--backward plan for fftw
+c Lmax: maximum degree in colatitude (dealiensing);
+c mmax: maximum degree in longitude (dealiensing);
+c ntmax: # of assembly points in THETA (ntmax >= 2*Lmax);
+c npmax: # of assembly points in PHI (npmax >= 2*mmax);
+c plan_forward: plan for the fftw
+ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
+ implicit none
+
+ integer Lmax,mmax,ntmax,npmax
+
+ real (kind=8) f(npmax,ntmax),gauwt(ntmax),p(0:Lmax,0:mmax,ntmax)
+! real (kind=8) wfftr(4*npmax+30) ! for absoft IMSL table
+ integer (kind=8) wfftr(2)
+ real (kind=8) ft(npmax)
+
+ complex (kind=8) flm(0:Lmax,0:mmax)
+ complex (kind=8) temp(0:mmax,ntmax)
+ integer k,L,m,i
+ real (kind=8) wt,wtfac,pi,one
+
+C
+C SUBROUTINE STARTS HERE
+C
+
+ one = 1.0
+ pi = 4.0*atan(one)
+ wtfac = sqrt(2.0*pi)/npmax
+
+ flm = 0.0
+! call dfftw_plan_dft_r2c_1d(plan_forward,npmax,ft,fcom,0)
+
+ do k = 1,ntmax
+ ft = f(:,k)
+! call df2trf(npmax,ft,f(1,k),wfftr) ! for absofr IMSL
+ call dfftw_execute_dft_r2c(wfftr(1),ft,temp(0,k))
+ enddo
+
+ do k = 1,ntmax
+ wt= gauwt(k)*wtfac
+ do L = 0,Lmax
+ flm(L,0)= flm(L,0)+p(L,0,k)*real(temp(0,k))*wt
+ enddo
+ do m = 1,mmax
+ do L = m,Lmax
+ flm(L,m)= flm(L,m)+p(L,m,k)*wt*temp(m,k)
+ enddo
+ enddo
+ enddo
+! call dfftw_destroy_plan(plan_forward)
+ return
+ end
Deleted: geodyn/3D/MoSST/trunk/matrices.f
===================================================================
--- geodyn/3D/MoSST/trunk/matrices.f 2006-10-30 23:07:45 UTC (rev 5120)
+++ geodyn/3D/MoSST/trunk/matrices.f 2006-10-31 20:59:39 UTC (rev 5121)
@@ -1,41 +0,0 @@
-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
-
Deleted: geodyn/3D/MoSST/trunk/miscs.f
===================================================================
--- geodyn/3D/MoSST/trunk/miscs.f 2006-10-30 23:07:45 UTC (rev 5120)
+++ geodyn/3D/MoSST/trunk/miscs.f 2006-10-31 20:59:39 UTC (rev 5121)
@@ -1,377 +0,0 @@
-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
-
Deleted: geodyn/3D/MoSST/trunk/mod_anomaly.f
===================================================================
--- geodyn/3D/MoSST/trunk/mod_anomaly.f 2006-10-30 23:07:45 UTC (rev 5120)
+++ geodyn/3D/MoSST/trunk/mod_anomaly.f 2006-10-31 20:59:39 UTC (rev 5121)
@@ -1,81 +0,0 @@
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- 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
-
Deleted: geodyn/3D/MoSST/trunk/mod_artdis.f
===================================================================
--- geodyn/3D/MoSST/trunk/mod_artdis.f 2006-10-30 23:07:45 UTC (rev 5120)
+++ geodyn/3D/MoSST/trunk/mod_artdis.f 2006-10-31 20:59:39 UTC (rev 5121)
@@ -1,66 +0,0 @@
-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
Deleted: geodyn/3D/MoSST/trunk/mod_dataio.f
===================================================================
--- geodyn/3D/MoSST/trunk/mod_dataio.f 2006-10-30 23:07:45 UTC (rev 5120)
+++ geodyn/3D/MoSST/trunk/mod_dataio.f 2006-10-31 20:59:39 UTC (rev 5121)
@@ -1,527 +0,0 @@
-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
-
Deleted: geodyn/3D/MoSST/trunk/mod_fields.f
===================================================================
--- geodyn/3D/MoSST/trunk/mod_fields.f 2006-10-30 23:07:45 UTC (rev 5120)
+++ geodyn/3D/MoSST/trunk/mod_fields.f 2006-10-31 20:59:39 UTC (rev 5121)
@@ -1,252 +0,0 @@
-!
-! 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
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
Deleted: geodyn/3D/MoSST/trunk/mod_matrices.f
===================================================================
--- geodyn/3D/MoSST/trunk/mod_matrices.f 2006-10-30 23:07:45 UTC (rev 5120)
+++ geodyn/3D/MoSST/trunk/mod_matrices.f 2006-10-31 20:59:39 UTC (rev 5121)
@@ -1,1860 +0,0 @@
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-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
-
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
Deleted: geodyn/3D/MoSST/trunk/mod_params.f
===================================================================
--- geodyn/3D/MoSST/trunk/mod_params.f 2006-10-30 23:07:45 UTC (rev 5120)
+++ geodyn/3D/MoSST/trunk/mod_params.f 2006-10-31 20:59:39 UTC (rev 5121)
@@ -1,273 +0,0 @@
- 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
Deleted: geodyn/3D/MoSST/trunk/mosst_cig.f
===================================================================
--- geodyn/3D/MoSST/trunk/mosst_cig.f 2006-10-30 23:07:45 UTC (rev 5120)
+++ geodyn/3D/MoSST/trunk/mosst_cig.f 2006-10-31 20:59:39 UTC (rev 5121)
@@ -1,219 +0,0 @@
- 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
-
Deleted: geodyn/3D/MoSST/trunk/parameter.data
===================================================================
--- geodyn/3D/MoSST/trunk/parameter.data 2006-10-30 23:07:45 UTC (rev 5120)
+++ geodyn/3D/MoSST/trunk/parameter.data 2006-10-31 20:59:39 UTC (rev 5121)
@@ -1,68 +0,0 @@
- $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"
- $
Deleted: geodyn/3D/MoSST/trunk/params_io.f
===================================================================
--- geodyn/3D/MoSST/trunk/params_io.f 2006-10-30 23:07:45 UTC (rev 5120)
+++ geodyn/3D/MoSST/trunk/params_io.f 2006-10-31 20:59:39 UTC (rev 5121)
@@ -1,380 +0,0 @@
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- 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
Deleted: geodyn/3D/MoSST/trunk/readme
===================================================================
--- geodyn/3D/MoSST/trunk/readme 2006-10-30 23:07:45 UTC (rev 5120)
+++ geodyn/3D/MoSST/trunk/readme 2006-10-31 20:59:39 UTC (rev 5121)
@@ -1,4 +0,0 @@
-This directory holds all modules, subroutines and the main code of
-the MoSST for CIG.
-
-Weijia Kuang 10/2006
Deleted: geodyn/3D/MoSST/trunk/solvers.f
===================================================================
--- geodyn/3D/MoSST/trunk/solvers.f 2006-10-30 23:07:45 UTC (rev 5120)
+++ geodyn/3D/MoSST/trunk/solvers.f 2006-10-31 20:59:39 UTC (rev 5121)
@@ -1,290 +0,0 @@
-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
-
Added: geodyn/3D/MoSST/trunk/src/bcs.f
===================================================================
--- geodyn/3D/MoSST/trunk/src/bcs.f 2006-10-30 23:07:45 UTC (rev 5120)
+++ geodyn/3D/MoSST/trunk/src/bcs.f 2006-10-31 20:59:39 UTC (rev 5121)
@@ -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
+
+
Added: geodyn/3D/MoSST/trunk/src/evolutions.f
===================================================================
--- geodyn/3D/MoSST/trunk/src/evolutions.f 2006-10-30 23:07:45 UTC (rev 5120)
+++ geodyn/3D/MoSST/trunk/src/evolutions.f 2006-10-31 20:59:39 UTC (rev 5121)
@@ -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
+
Added: geodyn/3D/MoSST/trunk/src/forces.f
===================================================================
--- geodyn/3D/MoSST/trunk/src/forces.f 2006-10-30 23:07:45 UTC (rev 5120)
+++ geodyn/3D/MoSST/trunk/src/forces.f 2006-10-31 20:59:39 UTC (rev 5121)
@@ -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
+
Added: geodyn/3D/MoSST/trunk/src/matrices.f
===================================================================
--- geodyn/3D/MoSST/trunk/src/matrices.f 2006-10-30 23:07:45 UTC (rev 5120)
+++ geodyn/3D/MoSST/trunk/src/matrices.f 2006-10-31 20:59:39 UTC (rev 5121)
@@ -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
+
Added: geodyn/3D/MoSST/trunk/src/miscs.f
===================================================================
--- geodyn/3D/MoSST/trunk/src/miscs.f 2006-10-30 23:07:45 UTC (rev 5120)
+++ geodyn/3D/MoSST/trunk/src/miscs.f 2006-10-31 20:59:39 UTC (rev 5121)
@@ -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
+
Added: geodyn/3D/MoSST/trunk/src/mod_anomaly.f
===================================================================
--- geodyn/3D/MoSST/trunk/src/mod_anomaly.f 2006-10-30 23:07:45 UTC (rev 5120)
+++ geodyn/3D/MoSST/trunk/src/mod_anomaly.f 2006-10-31 20:59:39 UTC (rev 5121)
@@ -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
+
Added: geodyn/3D/MoSST/trunk/src/mod_artdis.f
===================================================================
--- geodyn/3D/MoSST/trunk/src/mod_artdis.f 2006-10-30 23:07:45 UTC (rev 5120)
+++ geodyn/3D/MoSST/trunk/src/mod_artdis.f 2006-10-31 20:59:39 UTC (rev 5121)
@@ -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
Added: geodyn/3D/MoSST/trunk/src/mod_dataio.f
===================================================================
--- geodyn/3D/MoSST/trunk/src/mod_dataio.f 2006-10-30 23:07:45 UTC (rev 5120)
+++ geodyn/3D/MoSST/trunk/src/mod_dataio.f 2006-10-31 20:59:39 UTC (rev 5121)
@@ -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
+
Added: geodyn/3D/MoSST/trunk/src/mod_fields.f
===================================================================
--- geodyn/3D/MoSST/trunk/src/mod_fields.f 2006-10-30 23:07:45 UTC (rev 5120)
+++ geodyn/3D/MoSST/trunk/src/mod_fields.f 2006-10-31 20:59:39 UTC (rev 5121)
@@ -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
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
Added: geodyn/3D/MoSST/trunk/src/mod_matrices.f
===================================================================
--- geodyn/3D/MoSST/trunk/src/mod_matrices.f 2006-10-30 23:07:45 UTC (rev 5120)
+++ geodyn/3D/MoSST/trunk/src/mod_matrices.f 2006-10-31 20:59:39 UTC (rev 5121)
@@ -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
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
Added: geodyn/3D/MoSST/trunk/src/mod_params.f
===================================================================
--- geodyn/3D/MoSST/trunk/src/mod_params.f 2006-10-30 23:07:45 UTC (rev 5120)
+++ geodyn/3D/MoSST/trunk/src/mod_params.f 2006-10-31 20:59:39 UTC (rev 5121)
@@ -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
Added: geodyn/3D/MoSST/trunk/src/mosst_cig.f
===================================================================
--- geodyn/3D/MoSST/trunk/src/mosst_cig.f 2006-10-30 23:07:45 UTC (rev 5120)
+++ geodyn/3D/MoSST/trunk/src/mosst_cig.f 2006-10-31 20:59:39 UTC (rev 5121)
@@ -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
+
Added: geodyn/3D/MoSST/trunk/src/parameter.data
===================================================================
--- geodyn/3D/MoSST/trunk/src/parameter.data 2006-10-30 23:07:45 UTC (rev 5120)
+++ geodyn/3D/MoSST/trunk/src/parameter.data 2006-10-31 20:59:39 UTC (rev 5121)
@@ -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"
+ $
Added: geodyn/3D/MoSST/trunk/src/params_io.f
===================================================================
--- geodyn/3D/MoSST/trunk/src/params_io.f 2006-10-30 23:07:45 UTC (rev 5120)
+++ geodyn/3D/MoSST/trunk/src/params_io.f 2006-10-31 20:59:39 UTC (rev 5121)
@@ -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
Added: geodyn/3D/MoSST/trunk/src/readme
===================================================================
--- geodyn/3D/MoSST/trunk/src/readme 2006-10-30 23:07:45 UTC (rev 5120)
+++ geodyn/3D/MoSST/trunk/src/readme 2006-10-31 20:59:39 UTC (rev 5121)
@@ -0,0 +1,4 @@
+This directory holds all modules, subroutines and the main code of
+the MoSST for CIG.
+
+Weijia Kuang 10/2006
Added: geodyn/3D/MoSST/trunk/src/solvers.f
===================================================================
--- geodyn/3D/MoSST/trunk/src/solvers.f 2006-10-30 23:07:45 UTC (rev 5120)
+++ geodyn/3D/MoSST/trunk/src/solvers.f 2006-10-31 20:59:39 UTC (rev 5121)
@@ -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
+
Added: geodyn/3D/MoSST/trunk/src/time_integ.f
===================================================================
--- geodyn/3D/MoSST/trunk/src/time_integ.f 2006-10-30 23:07:45 UTC (rev 5120)
+++ geodyn/3D/MoSST/trunk/src/time_integ.f 2006-10-31 20:59:39 UTC (rev 5121)
@@ -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
Deleted: geodyn/3D/MoSST/trunk/time_integ.f
===================================================================
--- geodyn/3D/MoSST/trunk/time_integ.f 2006-10-30 23:07:45 UTC (rev 5120)
+++ geodyn/3D/MoSST/trunk/time_integ.f 2006-10-31 20:59:39 UTC (rev 5121)
@@ -1,1093 +0,0 @@
-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
More information about the cig-commits
mailing list