[cig-commits] r3893 - / 3D 3D/MAG 3D/MAG/trunk 3D/MAG/trunk/doc
3D/MAG/trunk/src
wei at geodynamics.org
wei at geodynamics.org
Mon Jun 26 17:20:47 PDT 2006
Author: wei
Date: 2006-06-26 17:20:45 -0700 (Mon, 26 Jun 2006)
New Revision: 3893
Added:
3D/
3D/MAG/
3D/MAG/branches/
3D/MAG/tags/
3D/MAG/trunk/
3D/MAG/trunk/doc/
3D/MAG/trunk/doc/MAGDOC
3D/MAG/trunk/doc/PATHMAKE
3D/MAG/trunk/doc/README
3D/MAG/trunk/doc/VARIABLES
3D/MAG/trunk/src/
3D/MAG/trunk/src/amhd.f
3D/MAG/trunk/src/cftrig.f
3D/MAG/trunk/src/chebi.f
3D/MAG/trunk/src/chebtf.f
3D/MAG/trunk/src/cmbcoeff.f
3D/MAG/trunk/src/com1.f
3D/MAG/trunk/src/com2.f
3D/MAG/trunk/src/com3.f
3D/MAG/trunk/src/com4.f
3D/MAG/trunk/src/com5.f
3D/MAG/trunk/src/com6.f
3D/MAG/trunk/src/com7.f
3D/MAG/trunk/src/com8.f
3D/MAG/trunk/src/copydat.f
3D/MAG/trunk/src/dtchck.f
3D/MAG/trunk/src/fact.f
3D/MAG/trunk/src/fax.f
3D/MAG/trunk/src/fft99a.f
3D/MAG/trunk/src/fft99b.f
3D/MAG/trunk/src/fftrig.f
3D/MAG/trunk/src/filter.f
3D/MAG/trunk/src/fourtf.f
3D/MAG/trunk/src/gquad.f
3D/MAG/trunk/src/graphout.f
3D/MAG/trunk/src/graphout_org.f
3D/MAG/trunk/src/kei.f
3D/MAG/trunk/src/legtf.f
3D/MAG/trunk/src/ludc.f
3D/MAG/trunk/src/makefile
3D/MAG/trunk/src/mapdata.f
3D/MAG/trunk/src/mei.f
3D/MAG/trunk/src/movaout.f
3D/MAG/trunk/src/moveout.f
3D/MAG/trunk/src/movmout.f
3D/MAG/trunk/src/nl.f
3D/MAG/trunk/src/par.bnch0
3D/MAG/trunk/src/par.bnch0_copy
3D/MAG/trunk/src/par.bnch1
3D/MAG/trunk/src/param.f
3D/MAG/trunk/src/param32s1.f
3D/MAG/trunk/src/param32s4.f
3D/MAG/trunk/src/param32s6.f
3D/MAG/trunk/src/param96s6.f
3D/MAG/trunk/src/pbar.f
3D/MAG/trunk/src/prep.f
3D/MAG/trunk/src/prnt.f
3D/MAG/trunk/src/random.f
3D/MAG/trunk/src/rderiv.f
3D/MAG/trunk/src/rffti.f
3D/MAG/trunk/src/sgefa.f
3D/MAG/trunk/src/sgesl.f
3D/MAG/trunk/src/spectrum.f
3D/MAG/trunk/src/spherictf.f
3D/MAG/trunk/src/stopiteration.f
3D/MAG/trunk/src/stor.f
3D/MAG/trunk/src/vpassm.f
3D/MAG/trunk/src/wpassm.f
Log:
initial import
Added: 3D/MAG/trunk/doc/MAGDOC
===================================================================
--- 3D/MAG/trunk/doc/MAGDOC 2006-06-26 21:27:17 UTC (rev 3892)
+++ 3D/MAG/trunk/doc/MAGDOC 2006-06-27 00:20:45 UTC (rev 3893)
@@ -0,0 +1,322 @@
+**********************************************************************
+
+*** DOCUMENTATION OF PROGRAM MAG *************************************
+
+**********************************************************************
+
+The program magb solves the equation of magnetohydrodynamics and of
+heat transfer in a rotating spherical shell.
+
+The primary variables are: W - poloidal velocity scalar potential
+ Z - toroidal velocity scalar potential
+ S - entropy (temperature) perturbation
+ P - pressure perturbation
+ B - poloidal magnetic field potential
+ J - toroidal magnetic field potential
+These are expanded in spherical harmonic functions Ylm(theta,phi)
+(fully normalized) in the angular variables and in Chebycheff
+polynomia in the radial variable r. A spectral transform method
+with second-order time-stepping is used to solve the equations.
+Non-linear terms are calculated on a grid that is equidistant in
+phi (longitude), consists of the Gauss points (zeros of Legendre
+polynomia) in theta (latitude), and maxima of the Chebycheff
+polynomia in r (radius).
+Time-step control is by a Courant criterion based on both the
+fluid-velocity and the modified Alfven velocity (taking into account
+the effect of damping).
+For a (somewhat) more detailed description of the numerical technique
+see
+G.A. Glatzmeier, P. Olson, Highly supercritical thermal convection
+in a rotating spherical shell: centrifugal vs. radial gravity, Geophys.
+Astrophys. Fluid Dyn., 70, 113-136, 1993,
+P. Olson, G.A. Glatzmeier, Magnetoconvection in a rotating spherical
+shell: structure of flow in the outer core, Phys. Earth Planet. Int.,
+92, 109-118, 1995.
+
+**********************************************************************
+
+Further documentation:
+
+An (incomplete) list of the meaning of variable names including
+most of the input parameters can be found in VARIABLES
+
+**********************************************************************
+
+*** HOW TO RUN MAG *************************************************
+
+Files needed to run mag:
+
+1) The FORTRAN source code is contained in the following files:
+
+ param.f: Fixing parameters, copied by include statements
+ (different parameter files can be kept and linked by the
+ statement ln -sf <filename> param.f)
+ In order to change grid parameters, only the first line in
+ the parameter file must be edited. Meaning of parameters is:
+ nn: number of radial grid levels, must be of form 4*i+1,
+ where i is an integer
+ nj: number of grid points in colatitude, must be multiple of 4
+ and best of the form nj=p*2^i with i>1 and p=2,3, or 5
+ ni: must be mutiple of 2, should be set equal to nj/2
+ nnaf: number of Chebychev polynomia, must be <=nn. Usually set
+ to nn-2
+ minc: Imposed minc-fold symmetry in longitude (minc>=1). When
+ minc>1 restrictions on nj apply also to nja=nj/minc !
+
+ com1.f ... com8.f: commons blocks, copied by include
+
+ nl.f: contains main program
+
+ prep.f amhd.f legtf.f rderiv.f stor.f prnt.f ludc.f dtchck.f
+ kei.f mei.f pbar.f gquad.f random.f chebtf.f chebi.f rfft.f fact.f
+ cftrig.f fourtf.f fax.f fftrig.f sgesl.f sgefa.f fft99a.f fft99b.f
+ vpassm.f wpassm.f graphout.f moveout.f movaout.f movmout.f spectrum.f
+ mapdata.f copydat.f stopiteration.f filter.f spherictf.f:
+ each file contains one subroutine
+
+2) A makefile, (named 'makefile'), which must be executed by
+ 'make' to compile and link the program. The name
+ of the executionable is "magx".
+ If several executionable files with different grid parameters
+ are to be kept, the files should be renamed after compilation,
+ e.g. 'mv magx magx64s4' for a case with truncation parameter
+ lmax=64 and assumed 4-fold symmetry of the solution (minc=4).
+3) File with the input parameters in NAMELIST format, must be assigned
+ to standard input.
+ Example: The command > magx <par.test >p.test3 &
+ runs the executionable "magx" with the input file "par.test"
+ and writes standard output on the file "p.test3".
+
+
+INPUT PARAMETERS
+
+Parameters have a pre-defined (default) values. They are read through
+a namelist in the subroutine "prep".
+
+*************** NAMELIST "CONTRL" **************************************
+
+***INPUT, OUTPUT, STEPPING CONTROL, INITIALIZATION OF THE RUN **********
+outfile: Name of output files (pre-fixes d., g., l., ls., me., ma., mm.,
+ are added)
+infile: Complete name of file from which initial values are read
+ (restart-file).
+runid: arbitrary text of up to 64 characters to describe the model
+init: set 1 to start from scratch (random noise initial condition)
+ set 0 to start from a previous result obtained on the same
+ grid and has been written into a file named d[0-9].<name>
+ set to a value >= 100 to start from an initial temperature
+ perturbation of one given mode l,m. Here, m is given by the two
+ last digits of init and l by the preceding digits; for example
+ init=606 means that a temperature perturbation of l=6 and m=6
+ is imposed.
+samp: amplitude of initial perturbation (whether random or single mode)
+nstep: do one block of nstep time step before producing a summary
+ printout of some diagnostics standard output. nstep should be even.
+nprnt: do one 'superblock' consisting of nprnt blocks of nstep time
+ steps each, before saving all data in file 'd[0-9].name'. If
+ nstor=1 there is no number added after the 'd', if nstor>1 the
+ number is incremented by one for each new superblock, starting
+ with zero.
+nstor: do nstor 'superblocks' consisting of nstep*nprnt time steps
+ before terminating the process. The total number of time steps
+ is nstep*nprnt*nstor. nstor must be <=10.
+ngform: Write data at grid points for graphics processing and other
+ post-processing (programs column.f diagnos.f)
+ into file 'g[0-9].<name>' each time a superblock is written.
+ ngform=2: unformatted file, ngform=1: formatted file
+ ngform=0: nothing written, ngform=-1: comment lines are
+ included into file for easier reading (cannot be used
+ for graphics processing in this form)
+ngrad: Output on graphics file for each ngrad'th radial point.
+ngcolat: Output on graphics file every ngcolat'th point in colatitude.
+nglon: Output on graphics file every nglon'th point in longitude.
+nfilt: If>0 apply filter of type F(l)=exp[-(l/alfilt)^nfil] to the
+ radial component of the magnetic field on the outer radius (kc=1)
+ before writing data into graphics file (for alfilt >0).
+ When alfilt<0 then apply filter F(l)=(1+sin(pi*(l-nfilt)/alfilt)
+ as long as |l-nfilt|<0.5*alfilt, and F=1 and F=0 respectively
+ for small/large l.
+alfilt: See under nfilt
+ivfilt: If >0 apply the same filter as above to the radial velocity at
+ radial level ivfilt and write the result into graphics file at
+ the first radial location (kc=1)
+dipfilt: If nfilt>0 multiply axial dipole component of B_r on outer surface
+ by dipfilt in graphics output
+nlogstep: write data on logfile (prefix l.) after each nlogstep steps.
+nplog: if >0 write velocity values at specific points of the grid on
+ separate logfile (prefix "lp.") after every nplog steps (see for
+ arrays vrpoint, vppoint, vtpoint in subroutine amhd for details)
+iscale: determines which diffusivity is used for scaling of time,
+ velocity and energy. 1=viscous, 2=therm., 3=magn.
+enscale: in output listings, energies are multiplied by enscale
+treset: (LOGICAL) if true reset time and step counter to zero
+ when starting from a stored dataset
+tipdipole: when starting calculation without imposed symmetry (minc=1)
+ from a data file with symmetry (minc>1), add an equatorial
+ dipole component with tipdipole times the magnitude of the
+ polar dipole
+amps: Option for rescaling temperature perturbation (from restart
+ file) by factor amps (if not equal 1)
+ampw: Same for poloidal velocity
+ampz: Same for toroidal velocity
+ampb: Same for poloidal magnetic field
+ampj: Same for toroidal magnetic field
+ifvfrz: (logical) if true, do not update velocity during iteration
+ifbfrz: (logical) if true, do not update mag. field during iteration
+ifsfrz: (logical) if true, do not update temperature during iteration
+
+***TIME STEP CONTROL **************************************************
+dtmin: Minimum time step (in sec). If the dynamically determined
+ time step becomes less, the program terminates.
+dtmax: Maximum (and usually initial) time step. This must be less than
+ 0.25*ek. Between dtmax and dtmin the actual time step
+ is controlled by a Courant criterion (see below).
+dtstart: Initial time step. If dtmax=0, dtmax is used for the initial
+ time step when init>0 and the last time step used in the previous
+ run (stored in the restart file) is used when init=0.
+courfac:controls the contribution of the fluid velocity to the Courant
+ time step limit (a larger value leads to smaller dt)
+alffac: controls the contribution of the (modified) Alfven velocity
+ to the Courant time step limit (a larger value leads to smaller dt)
+icour: check Courant criterion after each icour time steps (even number)
+
+***PHYSICAL CONTROL PARAMETERS ****************************************
+ra: Rayleigh number (defined with gravity on outer boundary)
+ek: Ekman number
+pr: Prandtl number
+prmag: Magnetic Prandtl number
+radratio: Ratio of inner to outer radius
+bpeak: peak value of magnetic field imposed by bound. cond. at ICB
+ (also when imagcon=0, bpeak controls the initial magnetic
+ field: toroidal when bpeak>0, poloidal dipole when bpeak<0!)
+epsc0: Volumetric rate of internal heating (not tested !)
+
+***BOUNDARY CONDITIONS AT INNER AND OUTER RADII *************************
+ktops: thermal boundary condition at CMB. 1-fixed temp, 2-fixed radial
+ heat flow. (ktops=2 not tested !).
+kbots: thermal boundary condition at ICB. As above.
+ktopv: velocity condition at CMB. 1-free, 2-rigid.
+kbotv: velocity condition at ICB. As above.
+ktopb: =1 for insulating inner core =2: ideally conducting inner core
+kbotb: =1 for insulating mantle =2: not implemented !
+imagcon: <0 imposed poloidal field (l=1,m=0) at ICB
+ >=0 imposed toroidal field (l=2,m=0) at ICB
+ >=10 imposed toroidal field (l=2,m=0) at both CMB and ICB
+ (same amplitude and same sign if =10, opposite sign if =11)
+cmb: If >0, thin conducting layer at bottom of mantle (not tested!)
+
+***HYPERDIFFUSIVITIES **************************************************
+
+
+difamp: Amplitude of hyperdiffusivities
+ldif: Hyperdiffusivites applied for harmonic degrees l >= ldif
+ldifexp: Exponent for increase of hyperdiffusities with l
+ (analytical details see definition of ql(lm,11) in prep.f)
+
+***PARAMETERS FOR GENERATING MOVIE FILES *******************************
+
+imovopt: three-digit integer number, options for generating movie files
+ Last digit>0 - write B_z, W_z (vorticity) and T in the equatorial
+ plane on file with prefix "me."
+ 2nd last digit>0 - write longitudinally averaged B_phi, j_phi and
+ v_phi on file with prefix "ma."
+ 3rd last digit>0 - write B_r at outer surface and B_r and v_r at mid-
+ depth on file with prefix "mm."
+ 4th last digit>0 - write spherical harmonic coeffs for
+ poloidal field at outer boundary and for velocity
+ potentials at radial level given by this digit
+ on file with prefix "cc."
+iframes: write altogether iframes frames on the movie files
+tmovstart: time at which to start writing movie-frames
+tmovstep: time increments for writing movie-frames
+
+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+
+POSTPROCESSING
+
+
+The program produces a set of output files for further
+processing:
+A summary of the program run is in the standard output file.
+l.[outfile] lists a set of diagnostic values each nlogstep time-steps
+ls.[outfile] spectra of kinetic energy and magnetic field every nprint
+ timesteps, sorted for modes with equal l, and additionally sorted
+ for modes with equal m.
+g.[outfile] or g[i].[outfile], where i=1,2,..9 (optional, written
+ when ngstep>0): contains temperature, velocity and mag. field compo-
+ nents for graphics processing (idl-program magsym on gibbs)
+d.[outfile] or d[i].outfile: restart-files with the complete set of
+ variables (stored as spectral values l,m in the angular
+ coordinates for radial grid-levels)
+lp.[outfile] written when nplog>0. Velocity at specific points written
+ every nplog'th time step.
+me.[outfile] written when last digit of imovopt>0. Values in the equatorial
+ plane for producing movie (idl-program movie2 on gibbs)
+mm.[outfile] written when first digit of imovopt>0. Values on spherical sur-
+ faces for producing movie (idl-program movie3 on gibbs)
+ma.[outfile] written when second digit of imovopt>0. Longitudianal averages
+ for producing movie (movie program does not yet exist)
+
+IF one of these files already exists, the program will not run.
+
+****************************************************************
+
+The standard output file contains first a summary of grid paramaters
+and of all process control and physical parameters that occur
+in the namelist statements. It lists the values of non-dimensional
+parameters and of the various diffusive time-scales.
+ Then, at the end of each block it lists a number of diagnostic
+values:
+
+dt: actual time step
+dtrmin: Courant time calculated with radial velocities
+dthmin: Courant time calculated with horizontal velocities
+cour: maximum inverse Courant time based on radial fluid velocity
+couh: maximum inverse Courant time based on horizontal fluid velocity
+alfr: maximum inverse Courant time based on radial modified Alfven velocity
+alfh: maximum inverse Courant time based on horiz. modified Alfven velocity
+ (in addition, the radial level at which the maximum is reached is
+ indicated)
+ent: total energy
+env: kinetic energy
+enb: magnetic energy
+
+The meaning of other quantities is obvious.
+
+For the primary variables, the modes for which they assume their
+abs. maximum and the maximum are printed. Modification by urc:
+Maxima are determined for the toroidal potential multiplied by
+l/r, and for poloidal potentials multiplied by l(l+1)/r^2,
+in order to find the modes which exhibit the maximum longitudinal
+toroidal velocity (field strength) and the maximum radial velocity
+(field strength), respectively.
+
+*********************************************************************
+
+l.[outfile]
+
+printed every nlogstep time steps one record is printed that contains:
+1) time
+2) mean kinetic energy density
+3) mean poloidal kinetic energy density
+4) mean magnetic energy density
+5) mean poloidal magnetic energy density
+6) mean axisymmetric toroidal kinetic energy density
+7) mean axisymmetric poloidal kinetic energy density
+8) mean axisymmetric poloidal magnetic energy density
+9) mean axisymmetric toroidal magnetic energy density
+10) mean top heatflow (nusselt number)
+11) mean bottom heatflow (nusselt number)
+
+*********************************************************************
+
+ls.[outfile]
+
+printed each nprint time steps are four records with time being the
+first variable followed by the spectral power of kinetic and mag-
+netic energy, respectively, as a function of harmonic degree l,
+from l=0 to lmax (first two records in a block) and spectral power
+as function of harmonic order m in the last two records of a block.
+
+*********************************************************************
Added: 3D/MAG/trunk/doc/PATHMAKE
===================================================================
--- 3D/MAG/trunk/doc/PATHMAKE 2006-06-26 21:27:17 UTC (rev 3892)
+++ 3D/MAG/trunk/doc/PATHMAKE 2006-06-27 00:20:45 UTC (rev 3893)
@@ -0,0 +1,30 @@
+%Create a path for execution of magx (an example; use your path)
+$ printenv PATH
+$ PATH=$PATH:/home/dynamo/magCIG
+$ export PATH
+
+% make, using existing param.f grid and symmetry
+$ make
+
+%note that makefile uses -g77 or other Fortran compiler,
+and creates executable, either magx(default) or magxYYsZ,
+where yy=spherical harmonic trunction and Z=longitudinal symmetry
+
+%execution statement examples
+
+%input from par.bnch0, screen output, foreground
+$ magx32s4 <par.bnch0
+
+%input from par.bnch0, screen output to p.bench0, background
+$ magx32s4 <par.bnch0 >p.bench0 &
+
+% to restart run using d-file from same directory, changes in par-file:
+infile="filename",
+init=0,
+
+% to change grids or symmetry (in param.f) needs recompile
+parameter (nn=25,ni=144,nj=288,nnaf=23,minc=6)
+minc is the m-fold symmetry and nj/3 gives lmax
+param32s6.f and param32s4.f are examples of param.f
+param.f is what the code looks for and needs to be changed for remaking
+
Added: 3D/MAG/trunk/doc/README
===================================================================
--- 3D/MAG/trunk/doc/README 2006-06-26 21:27:17 UTC (rev 3892)
+++ 3D/MAG/trunk/doc/README 2006-06-27 00:20:45 UTC (rev 3893)
@@ -0,0 +1,93 @@
+
+This directory contains a serial version of Gary Glatzmaier's
+rotating spherical convection/magnetoconvection/dynamo code,
+modified by Uli Christensen and Peter Olson, named "mag".
+
+The code solves the nondimensional Boussinesq equations for
+time-dependent thermal convection in a rotating spherical
+shell filled with an electrically conducting fluid.
+
+The equations of motion are:
+the Navier-Stokes equation including Coriolis, Lorentz,Buoyancy,
+pressure, viscous, and inertial terms; the heat equation including
+advection, diffusion, and uniform-density heat sources; the continuity
+equation for velocity and Gauss' law for magnetic field, and the
+induction equation for the magnetic field.
+
+All variables are nondimensional; time scale is viscous
+diffusion, length scale is shell thickness,temperature scale
+is boundary temperature difference, magnetic field and electric
+currents use Elsasser number scaling.
+
+A variety of boundary and initial conditions are selected as options.
+
+Mag uses toroidal-poloidal decomposition for velocity and magnetic
+field with explicit timesteps.Linear terms are evaluated spectrally
+(spherical harmonics plus Chebycheff polynomials in radius) and nonlinear
+terms are evaluated on a spherical grid.
+
+Additional technical information is found in:
+Olson, P. & Glatzmaier, G.A.,Geophys Astrophys Fluid Dyn 92, 109, 1995;
+Phil Trans R Soc Lond A354, 1413, 1996
+Olson, P. Christensen, U, Glatzmaier, G.A. J Geophys.Res. 104, 10383, 1999
+Christensen, U, Olson, P, Glatzmaier, G.A. Geophys. J. Int 138, 393, 1999
+Christensen, et al, Phys Earth Planet Int 128, 25, 2001 (benchmark cases)
+(plus more recent papers by the same authors)
+
+
+This directory contains:
+
+1) The set of FORTRAN source code files with suffix ".f".
+This includes sample grid parameter value files with names like
+"param32s4.f" for a coarse grid (up to 32 spherical
+harmonics, 24 radial grid intervals, and 4-fold symmetry
+in phi).
+
+2) A makefile named "makefile".
+3) Two documentation files named "MAGDOC" and "VARIABLES".
+ The first gives an overview over the components of the code,
+ input parameters, structure of output files, etc.
+ The second explains the meaning of many of the important
+ variables and arrays used in the code. Both documentation
+ files may not be entirely up-to-date!!
+4) Sample files with input parameters, par.XXX. The case par.bnch0
+ is for rotating convection at an Ekman number of 1E-3,
+ starting from a conductive temperature perturbation with
+ imposed perturbation with l=4, m=4, and running for a short time.
+ This is the "benchmark0" test case in Christensen et al, 2001.
+ An other input file is par.bnch1, the dynamo "benchmark1" case
+ in Christensen et al.
+5) Output files "ls.benchX", "l.benchX", "g.benchx", and "d.benchx"
+ obtained with short runs on a Appro (Opteron) workstation
+ Explanations of the contents of these files are found
+ in MAGDOC.
+
+
+For test-running the code, do the following steps:
+
+0) Uncompress all files, and create a path (see PATHMAKE)
+1) ln -sf param32s4.f param.f [Link grid parameter file to "param.f"
+ which enters through "include" state-
+ ments into most subroutines].
+
+2) make [Compile the program].
+
+3) mv magx magx32s6 [Renaming, optional]
+
+4) magx32s4 <par.bnchX >p.benchX & [Background executin the bench input file]
+ (If there is a problem with the par.bnch files, modify the last
+ lines, which read:
+
+ icour=4
+ &end
+ &bounds
+ &end
+
+ (Also, instead of the "&", perhaps a "$" may be required).
+
+5) Compare output files
+
+6) REMEMBER TO DELETE, MOVE, or RENAME ALL OUTPUT FILES IN CURRENT
+ DIRECTORY BEFORE RE-RUNNING WITH THE SAME "output" FILENAME -- RETAINING
+ SAME-NAMED OUTPUT FILES IN THE CURRENT DIRECTORY CAUSES MAG TO CRASH!!
+
Added: 3D/MAG/trunk/doc/VARIABLES
===================================================================
--- 3D/MAG/trunk/doc/VARIABLES 2006-06-26 21:27:17 UTC (rev 3892)
+++ 3D/MAG/trunk/doc/VARIABLES 2006-06-27 00:20:45 UTC (rev 3893)
@@ -0,0 +1,412 @@
+This is a documentation of variables and names used in the
+program set in magbous
+
+adrke: : axisymmetric toroidal kinetic energy (diagnostic)
+ai: : imaginary unit = complex(0,1)
+aj:(nlma,nn+1) : poloidal magnetic field potential (spectral form)
+ the second index is either the Chebycheff degree (n)
+ or the radial grid point (kc)
+ajmat(nn,nn,lmax): LU-decomposed matrix from Chebycheff collocation of
+ tor. induction equation. Built in ludc, used in amhd.
+aleg1: (nlma,ni) : Value of associated Legendre function at grid points
+aleg2: (nlma,ni) : Value of associated Legendre function, multiplied with
+ Gaussian weight, at grid points
+aleg3: (nlma,ni) : Value of derivative of associated Legendre function
+ multiplied with sin(theta) at grid points
+alfilt: INPUT: Filter parameter for B_r in graphics output, see nfilt
+alffac: INPUT: controls the contribution of the (modified)
+ Alfven velocity to the Courant time step limit
+ (see under "courfac"). The modified Alfven velocity
+ is given by
+ v_alfven' = (v_a)^2 / {(v_a)^2 +[pi*(eta+nu)/delx]^2}
+ where v_a = B/sqrt(mu*rho) and delx is the Courant
+ length (either delxr or delxh)
+alpha: INPUT: =0 linear terms in the equations are treated fully explicit,
+ =1 linear terms are treated fully implicit, =0.5: Crank-N.
+alumn0: : factor for scaling heat flow in output
+amcke: : axisymmetric poloidal kinetic energy
+amhd: SUBROUTINE: the "workhorse" of the program, advance solution by
+ nstep time steps
+amps: INPUT: can be used to re-scale entropy
+ampj: INPUT: can be used to re-scale toroidal magn. field
+ampb: INPUT: can be used to re-scale poloidal magn. field
+ampw: INPUT: can be used to re-scale poloidal velocity
+ampz: INPUT: can be used to re-scale toroidal velocity
+anorm: : = sqrt(2/[nn+1])
+apome: : axisymmetric poloidal magnetic field energy
+atome: : axisymmetric toroidal magnetic field energy
+b: (nlma,nn+1) : poloidal mag. field potential (spectral form, see aj)
+bleg1: (lmax) : auxiliary array for calculation of aleg1
+bleg2: (lmax) : auxiliary array for calculation of aleg2
+bleg3: (lmax) : auxiliary array for calculation of aleg3
+bmat(nn,nn,lmax):: LU-decomposed matrix from Chebycheff collocation of
+ pol. induction equation. Built in ludc, used in amhd.
+bnlc1: (nja/2,ni): bnlr1 stored in complex form
+bnlc2: (nja/2,ni): bnlr2 stored in complex form
+bnlc3: (nja/2,ni): bnlr3 stored in complex form
+bnlr1: (nja,ni) : nonlinear products for updating b (on grid points)
+bnlr2: (nja,ni) : nonlinear products for updating aj (on grid points)
+bnlr3: (nja,ni) : nonlinear products for updating aj (on grid points)
+bots(0:lmax,0:mmax): INPUT: harmonic coefficients of prescribed temperature
+ (entropy) on inner boundary
+br: (nja,ni) : = r^2 * B_r on gridpoints
+brc: : br stored as complex array
+bscl: : = dt * radtop^2
+bt: (nja,ni) : = r * sin(theta) *b_theta
+btrdt: (ni) : used in movmout to calculate j_phi
+bts: (ni,3) : used in movmout to calculate j_phi
+btc: : bt stored as complex array
+bp: (nja,ni) : = r * sin(theta) * b_phi
+bpc: : bp stored as complex array
+bpeak: INPUT: maximum value of imposed field on boundaries
+bpeakbot: : maximum value of imposed field on inner boundary
+bpeaktop: : maximum value of imposed field on outer boundary
+cbr: (nja,ni) : = r^2 * curl (B) * e_r
+cbrc: : cbr stored as complex array
+cbt: (nja,ni) : = r * sin(theta) * curl (B) * e_theta
+cbtc: : ctr stored as complex array
+cbp: (nja,ni) : = r * sin(theta) * curl (B) * e_phi
+cbpc: : cpb stored as complex array
+cheb: (nn,nn) : cheb(i,j) = value of Ch. polyn. i at grid point j
+chebi: SUBROUTINE: initialize subroutine chebtf
+chebtf:SUBROUTINE: multiple fast Chebycheff transform
+clm: (lmax,mmax) : normalization factors of spherical harmonics
+cmb: INPUT: integrated conductivity of thin D"-layer
+colat: (ni) : vector of colatitudes (Gauss points), local array in
+ subroutine prep
+courfac: INPUT: factor controlling the time step as fraction of
+ courant advection length. The time step is limited to
+ dt < min( dx/[ courfac * v + alffac * v_alfven' ] )
+cvr: (nja,ni) : =r^2 * curl(v) * e_r
+cvrc: : cvr stored as complex array
+db: (nlma,nn+1) : radial deriv. of pol. mag. potential (spectral form, see aj)
+dbdt:(nlma,nn,2) : time derivative of pol. magn. pot. b
+dcheb: (nn,nn) : dcheb(i,j) = 1st derivative of Ch. polyn. i at grid point j
+d2cheb: (nn,nn) : d2cheb(i,j) = 2nd derivative of Ch. polyn. i at grid point j
+d3cheb: (nn,nn) : d2cheb(i,j) = 3rd derivative of Ch. polyn. i at grid point j
+ddb:(nlma,nn+1) : 2nd rad. derivative of pol. mag. potential b
+ddj:(nlma,nn+1) : 2nd rad. deriv. of tor. magn. potential aj
+ddw:(nlma,nn+1) : 0.25 * 2nd radial derivative of pol. velocity pot. w
+ddz:(nlma,nn+1) : 0.25 * 2nd radial derivative of tor. velocity pot. z
+djdt:(nlma,nn,2) : time derivative of tor. magn. pot. z
+dpdt:(nlma,nn,2) : time derivative of pressure
+dsdt:(nlma,nn,2) : time derivative of temperature (entropy)
+dw:(nlma,nn+1) : 0.50 * radial derivative of pol. velocity pot. w
+dwdt:(nlma,nn,2) : time derivative of pol. velocity pot. w
+dz:(nlma,nn+1) : 0.50 * radial derivative of tor. velocity pot. z
+dzdt:(nlma,nn,2) : time derivative of tor. velocity pot. z
+delxh(nn) : horizontal Courant length squared
+delxr(nn) : radial Courant length
+difamp: INPUT: amplitude of hyperdiffusivity
+ D=D*(1 + difamp *[(l+1-ldif)/(lmax+1-ldif)]^ldifexp)
+ when l>ldif
+dipfilt: INPUT: If nfilt>0 multiply axial dipole component of B_r on outer
+ surface by dipfilt in graphics file
+dj: (nlma,nn+1) : radial deriv. of tor. magn. potential (spectral form, see aj)
+dt: : current time step
+dtchck:SUBROUTINE: controls time step
+dth: : Courant time based on horiz. velocity + Alfven veloc.
+dtmax: INPUT: Upper limit on time step (and initial step)
+dtmin: : Lower limit on time step (stop when dt < dtmin)
+dtold: : Time step of previous iterative step
+dtr: : Courant time based on radial velocity + Alfven veloc.
+dtstart: INPUT: Initial time step. If =0, dtmax, or when beginning
+ from restart file, the old dt is taken
+dvpdr: (nja,ni) : = d [r * sin(theta) * v_phi]/dr on gridpoints
+dvpdrc: : dvpdr stored as complex array
+dvpdp: (nja,ni) : = d [r * sin(theta) * v_phi]/dphi on gridpoints
+dvpdpc: : dvpdp stored as complex array
+dvrdp: (nja,ni) : = d [r^2 * v_r]/dphi on gridpoints
+dvrdpc: : dvrdp stored as complex array
+dvrdr: (nja,ni) : = d [r^2 * v_r]/dr on gridpoints
+dvrdrc: : dvrdr stored as complex array
+dvrdt: (nja,ni) : = sin(theta) * d [r^2 * v_r]/dtheta on gridpoints
+dvrdtc: : dvrdt stored as complex array
+dvtdp: (nja,ni) : = d [r *sin(theta) * v_theta]/dphi on gridpoints
+dvtdpc: : dvtdp stored as complex array
+dvtdr: (nja,ni) : = d [r * sin(theta) * v_theta]/dr on gridpoints
+dvtdrc: : dvtdr stored as complex array
+dw: (nlma,nn+1) : 0.5*times radial deriv of pol. velocity potential w
+dz: (nlma,nn+1) : 0.5*times radial deriv of tor. velocity potential z
+escale: : scaling factor for energies in output
+ek: INPUT: Ekman number
+enb: OUTPUT: magnetic energy
+ens: OUTPUT: thermal energy
+enscale: INPUT: in output listing, energies are multiplied by enscale
+ent: OUTPUT: total energy
+env: OUTPUT: kinetic energy
+epsc0: INPUT: internal heating rate
+flmb1: (nlma+..) : r-component of (v x B) term
+flmb2: (nlma+..) : theta-component of (v x B) term
+flmb3: (nlma+..) : phi-component of (v x B) term
+flms1: (nlma+..) : r-component of entropy advection term
+flms2: (nlma+..) : theta-component of entropy advection term
+flms3: (nlma+..) : phi-component of entropy advection term
+flmw1: (nlma+..) : r-component of v*grad(v) + Lorentz force term
+flmw2: (nlma+..) : theta-component of v*grad(v) + Lorentz force term
+flmw3: (nlma+..) : phi-component of v*grad(v) + Lorentz force term
+gauss: (ni) : vector with Gaussian weighting factors, local array
+ in subroutine prep
+gquad: SUBROUTINE: finds zeros and Gauss. weight of assc. Legendre fct.
+grafile: CHARACT : file name for data on spatial grid for graphics
+ prefix "g." added to outfile
+grav(nn): : gravity at radial levels
+ib(nn,lmax): : pivot array for LU-decomposition of matrix bmat
+ created in sgefa, used in sgesl
+ic: : stepping variable commonly used for steps in colatid.
+icour: INPUT: Courant criterion is checked each ICOUR'th time step
+idiftype: INPUT: controls radial variation of diffusivity, =0: no var.
+ifaxc: (13) : auxiliary array (factorization) for Chebycheff transform
+ifaxf: (13) : auxiliary array (factorization) for Fourier transform
+ifbfrz: INPUT: logical, if .T., do not update magnetic field
+ifirst: : =1 before first call of time-step checking routine,
+ =0 thereafter
+iframes: INPUT: write altogether iframes frames on the movie files
+ (see description under imovopt)
+ifsfrz: INPUT: logical, if .T., do not update temperature (entropy)
+ifvfrz: INPUT: logical, if .T., do not update velocity
+ij(nn,lmax): : pivot array for LU-decomposition of matrix ajmat
+ created in sgefa, used in sgesl
+imagcon: INPUT: <0 imposed poloidal field (l=1,m=0) at ICB
+ >=0 imposed toroidal field (l=2,m=0) at ICB
+ >=10 additionally imposed field at CMB, field
+ is of same sign and amplitude if imagcon=10
+ and of opposite sign if imagcon=11
+imovopt: INPUT: three-digit integer number, controls options
+ for generating movie-files.
+ Last digit>0 - write B_z, W_z (vortic) and T in the
+ equatorial plane on file with prefix "me."
+ 2nd last digit>0 - write longitud. averaged B_phi,
+ j_phi and v_phi on file with prefix "ma."
+ 3rd last digit>0 - write B_r at outer surface and
+ v_p and v_t at level given bi this digit on file
+ with prefix "mm."
+ 4th last digit>0 - write spherical harmonic coefs for
+ poloidal field at outer boundary and for velocity
+ potentials at radial level given by this digit
+ on file with prefix "cc."
+imovct: : counter variable for movie frames
+infile: CHA INPUT: name of input file for initial values (restart)
+init: INPUT: =0 start from dat-file, =1: random initial cond.,
+ =-1: hydro. condition from dat-file, magnetic random
+ >=100: initial temperature perturbation in a single
+ mode l,m. Here m is given by the last two digits of
+ init and l by the preceding digits.
+ip0(nn): : pivot array for LU-decomposition of matrix p0mat
+ created in sgefa, used in sgesl
+iprnt: : counting blocks in time iteration sequence with
+ printed output created at completion of block
+is(nn,lmax): : pivot array for LU-decomposition of matrix smat
+ created in sgefa, used in sgesl
+is0(nn): : pivot array for LU-decomposition of matrix s0mat
+ created in sgefa, used in sgesl
+iscale: INPUT: determines which diffusivity is used for scaling of
+ time, velocity, energy. 1=viscous, 2=therm., 3=magn.
+istep: : time step counter (routine amh)
+istor: : counting superblocks in time iteration sequence,
+ upon completion of superblock disk file with data saved
+ivfilt: INPUT: Apply filter to v_r at radial level ivfilt and right
+ into first radial position in graphics file, see nfilt
+iwp(nn,lmax): : pivot array for LU-decomposition of matrix wpmat
+ created in sgefa, used in sgesl
+iz(nn,lmax): : pivot array for LU-decomposition of matrix zmat
+ created in sgefa, used in sgesl
+k2k: (nn1) : auxiliary array for Chebycheff transform
+kc: : stepping variable commonly used for steps in radius
+kcour: : auxiliary variable for time step checking procedure
+kbotb: INPUT: magnetic bot condition =1 insulat., =2 perfect cond.
+kbotv: INPUT: mechan. bottom condition =1 free, =2 rigid
+kbots: INPUT: thermal bottom condition =1 fixed entropy, =2 flux
+kei: SUBROUTINE: calculates kinetic energy
+kstep: : global time step counter
+ktops: INPUT: thermal top condition =1 fixed entropy, =2 flux
+ktopb: INPUT: magnetic top condition =1 insulat., =2 perfect cond
+ktopv: INPUT: mechan. top condition =1 free, =2 rigid
+ldif: INPUT: control parameter for hyperdiffusivity, see difamp
+ldifexp: INPUT: control parameter for hyperdiffusivity, see difamp
+lm: : stepping variable used to cover all l and m
+ lm = m*(lmax+1)/minc - m*(m-minc)/(2*minc) +l-m+1
+lmax: : max. harmonic degree, calculated as (nj-1)/3
+logfile: CHARACT : file name for continuous log of enregies and other data
+ prefix "l." added to outfile
+lot: PARAM: =2*nlma (twice the number of harmonic modes)
+lpfile: CHARACT : file name continuous log of specified values
+ pre-fix "lp." added to outfile
+lsfile: CHARACT : file name for power spectra of magnetic and kinetic
+ as function of l and m; pre-fix "ls."
+ludc: SUBROUTINE: Chebychev collocation
+mclm: (nlma) : used to unscramble harmonic order m from variable lm
+mclma: (nlma) : = m/minc+1 for given lm (storage order of m)
+kei: SUBROUTINE: calculates magnetic energy
+minc: PARAM: if >1, minc-fold symmetry in longitude assumed
+mmax: : max. harmonic order, is the largest integer <= lmax
+ divisible by minc
+movafile: CHARACT: file name for movie data (longitudinal averages)
+ prefix "ma."
+movefile: CHARACT: file name for movie data in equatorial plane
+ prefix "me."
+movmfile: CHARACT: file name for movie data in map views
+ prefix "mm."
+n, nc: : stepping variables commonly used for steps over
+ Chebycheff polynomia
+ncp: PARAM: =nja/2 used for storage of points in phi in complex array
+nfilt: INPUT: Apply filter F(l)=exp(-[l/lfilt]^nfilt) to B_r on outer
+ surface in graphics output file (if nfilt>0 and alfilt>0)
+ When nfilt>0, alfilt<0, apply cos-tapered filtered
+ with cutoff at nfilt and taper width |alfilt|
+ngcolat: INPUT: graphics output on each ngcolat'th point in latitude
+ngform: INPUT: if .ne. 0, graphics output is written each time a re-
+ start file is (finally) written. ngform=1 or -1:
+ formatted graphics file, ngform=2: unformatted
+ for ngform=-1 additional comment lines are inserted
+ (this is to look at the file, not for graphics)
+nglon: INPUT: graphics output for each nglon'th point in longitude
+ngrad: INPUT: graphics output on each ngrad'th radial level
+ni: PARAM: # of grid points in colatide , must be even.
+nip1: PARAM: =ni+1
+nj: PARAM: # of grid points in longitude, nj/minc must be multiple
+ of four.
+nja:: : =nj/minc, # of actually needed grid points in phi
+njp1: PARAM: =nj+1
+nlaf: PARAM: = lmax+1
+nlafp1: PARAM: = lmax+2
+nlm: PARAM: = (mmax+1)*(mmax+2)/2
+nlma: PARAM: # of angular modes employed
+ nlma = mmax*(lmax+1)/minc - mmax*(mmax-minc)/(2*minc)
+ + lmax-mmax+1.
+nlmpa: PARAM: = nlma + mmax/minc + 1
+nlogstep: INPUT: write data on logfile (prefix l.) after each nlogstep steps.
+nmaf: PARAM: = mmax+1
+nmafa: PARAM: = mmax/minc+1
+nn: PARAM: # of radial grid points, nn-1 must be multiple of 4,
+ and contain no prime factors larger than 5
+nn1: PARAM: =nn-1
+nn2: PARAM: =nn-2
+nn3: PARAM: =nn-3
+nnp1: PARAM: =nn+1
+nnp2: PARAM: =nn+2
+nnaf: PARAM: # of radial chebychev modes, must be <= nn
+nnx2: PARAM: =2*nn
+nplog: INPUT: if >0 write velocity values at specific points of
+ the grid on separate logfile (prefix "lp.") after
+ every nplog steps (see for arrays vrpoint, vppoint,
+ vtpoint in subroutine amhd for details)
+nprnt: INPUT: # of printed output blocks created until next data
+ storage for restart
+nps2: PARAM: =(nn+1)/2
+nrp: PARAM: =nja+2 (# of points in phi +2)
+ns2: PARAM: =(nn-1)/2
+nstep: INPUT: # of time steps done until next printed output
+ (total # of time steps is nstep*nprnt*nstor)
+nstor: INPUT: # of data storages before program termination
+ntf: PARAM: =3*nja/2+1, used for Fourier transform array trigsf
+ocorevol: : volume of spherical shell (outer core)
+oek: : = 1. / Ekman number
+oekpm: : = 1. / (Ekman number * Mag.Prandtl number)
+oodt: : = 1. / dt (inverse time step)
+oosscl: : = 1. / dt
+opr: : = 1. / Prandtl number
+outfile: CH INPUT: Name of output files (pre-fixes d.,l.,ls.,g.,me.,ma.,mm.,
+ lp. added)
+p0mat(nn,nn): : LU-decomposed matrix from Chebycheff collocation of pol.
+ equation of motion, l=0-term for pressure. Constructed
+ in ludc, used in amhd
+pbar: SUBROUTINE: Calculates value of assoc. Legendre function
+pscale: : scaling pressure in output
+pr: INPUT: Prandtl number
+prmag: INPUT: Magnetic Prandtl number
+prnt: SUBROUTINE: print diagnostic data
+pscl: : = radtop^2
+qi: (ni,5) : array with various coefficients depending on colatid.
+ (look in subroutine prep, loop "do 32 " for details
+qk: (nn,16) : array with various coefficients depending on radius
+ (look in subroutine prep for details)
+ql: (nlma,10) : various expressions depending on l and m
+ (look in subrout. prep, loop "do 35" for details)
+qn: (nn,6) : Chebycheff integrals
+r: (nn) : vector with radial levels, r(1)=radtop, r(nn)=radbot
+ra: INPUT: Rayleigh number
+rapr: : = Rayleigh number / Prandtl number
+radbot: : radius of inner boundary
+radratio: INPUT: ratio of inner radius to outer radius
+radtop: : radius of outer boundary
+rderiv:SUBROUTINE: ?? radial derivative
+rffti: SUBROUTINE: ??
+rstfile: CHARACT : file name for data in spectral form ('restart data')
+ prefix "d." or "d0.", "d1." .... added to outfile
+runid: CHAR*64 : text identifying the run
+rva(nn): : auxiliary array used in prep
+rvap(nn): : auxiliary array used in kei, mei
+rvat(nn): : auxiliary array used in kei, mei
+rvb(nn): : auxiliary array used in prep, kei, mei
+rvc(nn): : auxiliary array used in kei, mei
+p: (nlma,nn+1) : pressure (spectral form)
+p00co: : = 4/sqrt(3)
+prep: SUBROUTINE: parameter input, set up auxiliary arrays, set
+ initial conditions, etc
+s: (nlma,nn+1) : entropy perturbation (spectral form)
+sc: (ncp,ni) : sr stored in complex form
+snlc1: (ncp,ni) : slnr1 stored in complex form
+snlc2: (ncp,ni) : slnr2 stored in complex form
+snlc3: (ncp,ni) : slnr3 stored in complex form
+snlr1: (nrp,ni) : nonlinear term (radial advection) for updating temperature
+snlr2: (nrp,ni) : nonlinear term (theta advection) for updating temperature
+snlr3: (nrp,ni) : nonlinear term (phi advection) for updating temperature
+sr: (nrp,ni) : temperature (entropy) on grid points
+s0mat(nn,nn): : LU-decomposed matrix from Chebycheff collocation of
+ temperature equation, l=0-term. Constructed
+ in ludc, used in amhd
+samp: INPUT: amplitude of initial entropy perturbation
+smat(nn,nn,lmax):: LU-decomposed matrix from Chebycheff collocation of
+ temperature equation. Built in ludc, used in amhd.
+sr: (nja,ni) : entropy on gridpoints
+src: : sr stored as complex array
+sscl: : = dt
+stor: SUBROUTINE: store data in restart file
+tei: SUBROUTINE: calculates thermal energy
+time: : time
+timediff: : time
+tipdipole: INPUT: rotate poloidal dipole term when beginning from
+ restart file
+tmovnext: : auxiliary variable (next output time) for movie file
+ generation
+tmovstart: INPUT: time at which to start writing movie-frames on m.*-file
+tmovstep: INPUT: time increments for writing movie-frames on m.*-file
+tops(0:lmax,0:mmax): INPUT: harmonic coefficients of prescribed temperature
+ (entropy) on outer boundary
+treset: INPUT: (LOGICAL) if true reset time and step counter to zero
+ when starting from a stored dataset
+trigsc: (nn) : auxiliary array for Chebycheff transform routine
+ created in chebi, used in chebtf
+trigsf: (ntf) : auxiliary array for Fourier transform routine
+ created in fftrig, used in fourtf
+tscale: : scaling of time in output
+up: (nja,3) : phi-component of velocity in equatorial plane for
+ three consecutive radial levels. Used in moveout to
+ calculate vorticity
+urdp: (nja) : derivative dv_r/dphi in equatorial plane, used in
+ moveout to calculate vorticity
+vr: (nja,ni) : = r^2 * v_r on grid points
+vrc: : vr stored as complex array
+vp: (nja,ni) : = c * sin(theta) * v_phi on grid points
+vpc: : vp stored as complex array
+vscale: : scaling of velocity in output
+vt: (nja,ni) : = r * sin(theta) * v_theta on grid points
+vtc: : vt stored as complex array
+w: (nlma,nn+1) : poloidal velocity potential (spectral form)
+wpmat(nn,nn,lmax): LU-decomposed matrix from Chebycheff collocation of
+ pol. equation of motion. Built in ludc, used in amhd.
+wnlc1: (nja/2,ni): wnlr1 stored in complex form
+wnlc2: (nja/2,ni): wnlr2 stored in complex form
+wnlc3: (nja/2,ni): wnlr3 stored in complex form
+wnlr1: (nja,ni) : nonlinear products for updating w (on grid points)
+wnlr2: (nja,ni) : nonlinear products for updating z (on grid points)
+wnlr3: (nja,ni) : nonlinear products for updating z (on grid points)
+work: (lot,nnp2) : work array used in Fourier and Chebycheff transforms
+wsave: (nn) : auxiliary array used for Chebycheff transform
+wscl: : = dt * radtop^2
+y00: : = 1/sqrt(4*pi)
+z: (nlma,nn+1) : toroidal velocity potential (spectral form)
+zscl: : = dt * radtop^2
+zmat(nn,nn,lmax):: LU-decomposed matrix from Chebycheff collocation of
+ tor. equation of motion. Built in ludc, used in amhd.
Added: 3D/MAG/trunk/src/amhd.f
===================================================================
--- 3D/MAG/trunk/src/amhd.f 2006-06-26 21:27:17 UTC (rev 3892)
+++ 3D/MAG/trunk/src/amhd.f 2006-06-27 00:20:45 UTC (rev 3893)
@@ -0,0 +1,1100 @@
+ subroutine amhd
+c
+c---------------------------------------------------------------
+ include 'param.f'
+ include 'com1.f'
+ include 'com2.f'
+ include 'com3.f'
+ include 'com4.f'
+ include 'com5.f'
+ include 'com6.f'
+ include 'com7.f'
+ include 'com8.f'
+c
+ complex flms1(nlmpa),flms2(nlmpa),flms3(nlmpa),
+ $flmw1(nlmpa),flmw2(nlmpa),flmw3(nlmpa),
+ $flmb1(nlmpa),flmb2(nlmpa),flmb3(nlmpa),flmkb(nlma,nnp1),
+ $ddj(nlma,nnp1),
+ $flmks(nlma,nnp1),dflmk(nlma,nnp1),
+ $ds(nlma,nnp1),dds(nlma,nnp1)
+c
+ dimension vr(nrp,ni),vt(nrp,ni),vp(nrp,ni),
+ $dvrdr(nrp,ni),dvtdr(nrp,ni),dvpdr(nrp,ni),
+ $cvr(nrp,ni),dvrdt(nrp,ni),dvrdp(nrp,ni),
+ $dvtdp(nrp,ni),dvpdp(nrp,ni),
+ $wnlr1(nrp,ni),wnlr2(nrp,ni),wnlr3(nrp,ni),
+ $br(nrp,ni),bt(nrp,ni),bp(nrp,ni),
+ $cbr(nrp,ni),cbt(nrp,ni),cbp(nrp,ni),
+ $bnlr1(nrp,ni),bnlr2(nrp,ni),bnlr3(nrp,ni),
+ $sr(nrp,ni),snlr1(nrp,ni),snlr2(nrp,ni),snlr3(nrp,ni),
+ $frl(nn),fim(nn),frl2(nnx2),fim2(nnx2)
+ dimension vrpoint(nnp1),vppoint(nnp1),vtpoint(nnp1)
+c
+ equivalence (vr,vrc),(vt,vtc),(vp,vpc),
+ $(dvrdr,dvrdrc),
+ $(dvtdr,dvtdrc),
+ $(dvpdr,dvpdrc),
+ $(cvr,cvrc),
+ $(dvrdt,dvrdtc),
+ $(dvrdp,dvrdpc),
+ $(dvtdp,dvtdpc),
+ $(dvpdp,dvpdpc),
+ $(wnlr1,wnlc1),(wnlr2,wnlc2),(wnlr3,wnlc3),
+ $(br,brc),(bt,btc),(bp,bpc),
+ $(cbr,cbrc),(cbt,cbtc),(cbp,cbpc),
+ $(bnlr1,bnlc1),(bnlr2,bnlc2),(bnlr3,bnlc3),
+ $(dj,flmkb),(ddw,ddj),
+ $(sr,sc),(snlr1,snlc1),(snlr2,snlc2),(snlr3,snlc3),
+ $(ddz,ds,flmks),(dddw,dds,dflmk)
+
+c
+ external stopiteration
+c---------------------------------------------------------------
+c
+ isignal=30
+ istop=0
+c
+ kcour=0
+ kc0=0
+ newdt=0
+ kel=0
+ toplum=0.
+ botlum=0.
+ vmax=0.
+ courmax=.0
+ couhmax=.0
+ kcrmax=0
+ kchmax=0
+ reyn=0.
+ bmax=0.
+ alfrmax=0.
+ alfhmax=0.
+ karmax=0
+ kahmax=0
+ elsa=0.
+ oz=0.
+c
+c **********************************************************************
+c integrate for nstep time steps.
+c nonlinear and coriolis terms via an explicit adams-bashforth method.
+c linear terms via an implicit method.
+c **********************************************************************
+c
+c *** loop written explicitly: do 1001 istep=1,nstep,2
+c
+ istep=-1
+ 100 istep=istep+2
+c
+ if(dtmin .eq. 0.) go to 1000
+c
+ call signal(isignal,stopiteration)
+ if(istop.gt.0) istep=nstep
+c
+ do 1002 inel=1,2
+c
+ if(inel .eq. 1) then
+ jnel=2
+ else
+ jnel=1
+ endif
+ kstep=kstep+1
+ lcour=0
+ if((icour.gt.0).and.(mod(kstep+icour-1,icour).eq.0
+ $ .or. kcour.gt.0)) then
+ lcour=1
+ dtr=100.*dtmax
+ dth2=dtr*dtr
+ endif
+ time=time+dt
+ if(istep .eq. nstep) kel=inel
+ if((iprnt.eq.nprnt) .and. (kel.eq.2))
+ $ call graphout(kc0,ngform)
+ if(newdt .ne. 0) then
+ call ludc
+ newdt=0
+ endif
+ w2=-dt/(2.*dtold)
+ w1=1.-w2
+ dtold=dt
+c
+c ********************************************************************
+c advection of entropy and momentum,
+c coriolis, centrifugal, and lorentz forces,
+c induction of magnetic field,
+c joule, viscous and internal heating.
+c ********************************************************************
+c
+c
+ do 200 kc=1,nn
+c
+c -legendre transform from (k,l,m) to (k,i,m)
+c
+ call legtf(kc)
+c
+c -fourier transform from (k,i,m) to (k,i,j)
+c
+ call fourtf(sc,work,trigsf,ifaxf,1,nrp,nja,ni,1)
+ call fourtf(vrc,work,trigsf,ifaxf,1,nrp,nja,ni,1)
+ call fourtf(vtc,work,trigsf,ifaxf,1,nrp,nja,ni,1)
+ call fourtf(vpc,work,trigsf,ifaxf,1,nrp,nja,ni,1)
+ call fourtf(cvrc,work,trigsf,ifaxf,1,nrp,nja,ni,1)
+ call fourtf(dvrdrc,work,trigsf,ifaxf,1,nrp,nja,ni,1)
+ call fourtf(dvtdrc,work,trigsf,ifaxf,1,nrp,nja,ni,1)
+ call fourtf(dvpdrc,work,trigsf,ifaxf,1,nrp,nja,ni,1)
+ call fourtf(dvrdtc,work,trigsf,ifaxf,1,nrp,nja,ni,1)
+ call fourtf(dvrdpc,work,trigsf,ifaxf,1,nrp,nja,ni,1)
+ call fourtf(dvtdpc,work,trigsf,ifaxf,1,nrp,nja,ni,1)
+ call fourtf(dvpdpc,work,trigsf,ifaxf,1,nrp,nja,ni,1)
+ call fourtf(brc,work,trigsf,ifaxf,1,nrp,nja,ni,1)
+ call fourtf(btc,work,trigsf,ifaxf,1,nrp,nja,ni,1)
+ call fourtf(bpc,work,trigsf,ifaxf,1,nrp,nja,ni,1)
+ call fourtf(cbrc,work,trigsf,ifaxf,1,nrp,nja,ni,1)
+ call fourtf(cbtc,work,trigsf,ifaxf,1,nrp,nja,ni,1)
+ call fourtf(cbpc,work,trigsf,ifaxf,1,nrp,nja,ni,1)
+c
+c -courant condition check
+c
+c urc modification: instead of the full Alfven velocity
+c a modified Alfven velocity is employed that takes
+c viscous and Joule damping into account. Different
+c Courant factors are used for the fluid velocity and
+c the such modified Alfven velocity
+c
+ valri2=(0.5*(1.+opm)/delxr(kc))**2
+ valhi2=(0.5*(1.+opm))**2/delxh2(kc)
+c
+ if(lcour .gt. 0) then
+ vrmax=0.
+ vh2max=0.
+c
+ do 210 ic=1,ni
+ do 211 jc=1,nja
+ vflr=abs(vr(jc,ic)*qk(kc,1))
+ valr2=oekpm*(br(jc,ic)*qk(kc,1))**2
+ valr=valr2/sqrt(valr2+valri2)
+ vrmax=max(vrmax,
+ $ courfac*vflr
+ $ +alffac*valr
+ $ )
+ vflh2=
+ $ (vt(jc,ic)*vt(jc,ic)+vp(jc,ic)*vp(jc,ic))*
+ $ qk(kc,1)*qi(ic,1)
+ valh2=
+ $ +(bt(jc,ic)*bt(jc,ic)+bp(jc,ic)*bp(jc,ic))*
+ $ oekpm*qk(kc,1)*qi(ic,1)
+ valh2m=valh2*valh2/(valh2+valhi2)
+ vh2max=max(vh2max,
+ $ courfac*courfac*vflh2
+ $ +alffac*alffac*valh2m
+ $ )
+ 211 continue
+ 210 continue
+ if(vrmax .ne. 0.) dtr=min(dtr,delxr(kc)/vrmax)
+ if(vh2max .ne. 0.) dth2=min(dth2,delxh2(kc)/vh2max)
+ endif
+c
+c -max velocity and magnetic field;
+c
+ if(kel .gt. 0) then
+ vmax1=0.
+ courmax1=.0
+ couhmax1=.0
+ bmax1=0.
+ alfrmax1=0.
+ alfhmax1=0.
+ do 230 ic=1,ni
+ do 231 jc=1,nja
+ vflr=vr(jc,ic)*qk(kc,1)
+ vflh2=
+ $ (vt(jc,ic)*vt(jc,ic)+vp(jc,ic)*vp(jc,ic))*
+ $ qk(kc,1)*qi(ic,1)
+ vmax1=max(vmax1,vflr*vflr+vflh2)
+ br2=(br(jc,ic)*qk(kc,1))**2
+ bh2=
+ $ +(bt(jc,ic)*bt(jc,ic)+bp(jc,ic)*bp(jc,ic))*
+ $ qk(kc,1)*qi(ic,1)
+ bmax1=max(bmax1,br2+bh2)
+ courmax1=max(courmax1,abs(vflr))
+ couhmax1=max(couhmax1,vflh2)
+ valr2=br2*oekpm
+ valh2=bh2*oekpm
+ alfrmax1=max(alfrmax1,valr2*valr2/(valr2+valri2))
+ alfhmax1=max(alfhmax1,valh2*valh2/(valh2+valhi2))
+ 231 continue
+ 230 continue
+ vmax=max(vmax,vmax1)
+ bmax=max(bmax,bmax1)
+c
+ courmax1=courmax1/delxr(kc)
+ if(courmax1.gt.courmax) then
+ courmax=courmax1
+ kcrmax=kc
+ endif
+ couhmax1=sqrt(couhmax1/delxh2(kc))
+ if(couhmax1.gt.couhmax) then
+ couhmax=couhmax1
+ kchmax=kc
+ endif
+ alfrmax1=sqrt(alfrmax1)/delxr(kc)
+ if(alfrmax1.gt.alfrmax) then
+ alfrmax=alfrmax1
+ karmax=kc
+ endif
+ alfhmax1=sqrt(alfhmax1/delxh2(kc))
+ if(alfhmax1.gt.alfhmax) then
+ alfhmax=alfhmax1
+ kahmax=kc
+ endif
+ endif
+c
+ if(nplog.ne.0) then
+ if(mod(kstep,nplog).eq.0) then
+ vrpoint(kc)=vr(1,ni/2)*qk(kc,1)/vscale
+ vppoint(kc)=vp(1,ni/2)*qk(kc,3)/(qi(ni/2,3)*vscale)
+ vtpoint(kc)=vp(1,ni/4)*qk(kc,3)/(qi(ni/4,3)*vscale)
+ endif
+ endif
+c
+c urc : graphics output
+c
+ if((mod(kc-1,ngrad).eq.0) .and. (iprnt.eq.nprnt) .and.
+ $ (kel.eq.2)) call graphout(kc,ngform)
+c
+c urc: movie output
+c
+ if(time/tscale.ge.tmovnext.and.imovct.le.iframes) then
+ if(kc.eq.nn) then
+ if(imovopt.ge.1000) then
+ kcv=imovopt/1000
+ call cmbcoeff(kcv)
+ endif
+ imovct=imovct+1
+ tmovnext=tmovnext+tmovstep
+ endif
+ kvp=mod(imovopt,1000)/100
+ if(mod(imovopt,10).ge.1) call moveout(kc)
+ if(mod(imovopt,100).ge.10) call movaout(kc)
+ if(mod(imovopt,1000).ge.100) call movmout(kc,kvp)
+ endif
+c
+c urc: decomposition of (br * u) at surface into poloidal
+c and toroidal parts
+c
+cc if(kc.eq.1 .and. iprnt.eq. nprnt .and. kel.eq.2) then
+cc do ic=1,ni
+cc do jc=1,nja
+cc bvp(jc,ic)= vp(jc,ic)
+cc bvt(jc,ic)= vt(jc,ic)
+cccc bvp(jc,ic)=br(jc,ic)*vp(jc,ic)
+cccc bvt(jc,ic)=br(jc,ic)*vt(jc,ic)
+cc enddo
+cc enddo
+cc call bvdecompose(bvp,bvt)
+cc endif
+c
+c -quadratic products in physical space
+c
+ do ic=1,ni
+ do jc=1,nja
+ wnlr1(jc,ic)=0. ! Inertia & Lorentz force, r-comp.
+ $ -qk(kc,1)*(vr(jc,ic)*(dvrdr(jc,ic)-
+ $ qk(kc,6)*vr(jc,ic))+qi(ic,1)*(vt(jc,ic)*
+ $ (dvrdt(jc,ic)-r(kc)*vt(jc,ic))+vp(jc,ic)*
+ $ (dvrdp(jc,ic)-r(kc)*vp(jc,ic))))
+ $ +oekpm*qi(ic,1)*(cbt(jc,ic)*bp(jc,ic)-
+ $ cbp(jc,ic)*bt(jc,ic))
+c
+ wnlr2(jc,ic)=0. ! Inertia & Lorentz force, t-comp.
+ $ +qk(kc,4)*qi(ic,1)*(vr(jc,ic)*
+ $ (-dvtdr(jc,ic))+vt(jc,ic)*(qi(ic,2)*
+ $ vt(jc,ic)+dvpdp(jc,ic)+dvrdr(jc,ic))+
+ $ vp(jc,ic)*(qi(ic,2)*vp(jc,ic)-dvtdp(jc,ic))
+ $ +oekpm*(cbp(jc,ic)*
+ $ br(jc,ic)-cbr(jc,ic)*bp(jc,ic)))
+c
+ wnlr3(jc,ic)=0. ! Inertia & Lorentz force, p-comp.
+ $ +qk(kc,4)*qi(ic,1)*(vr(jc,ic)*
+ $ (-dvpdr(jc,ic))-vt(jc,ic)*
+ $ (dvtdp(jc,ic)+cvr(jc,ic))-
+ $ vp(jc,ic)*dvpdp(jc,ic))
+ $ +oekpm*qk(kc,4)*qi(ic,1)*(cbr(jc,ic)*
+ $ bt(jc,ic)-cbt(jc,ic)*br(jc,ic))
+ enddo
+ enddo
+c
+ do ic=1,ni
+ do jc=1,nja
+ snlr1(jc,ic)=vr(jc,ic)*sr(jc,ic)
+ snlr2(jc,ic)=qk(kc,1)*qi(ic,1)*(vt(jc,ic)*sr(jc,ic))
+ snlr3(jc,ic)=qk(kc,1)*qi(ic,1)*(vp(jc,ic)*sr(jc,ic))
+ enddo
+ enddo
+c
+ do ic=1,ni
+ do jc=1,nja
+ bnlr1(jc,ic)=qi(ic,1)*(vt(jc,ic)*
+ $ bp(jc,ic)-vp(jc,ic)*bt(jc,ic))
+ bnlr2(jc,ic)=qk(kc,4)*qi(ic,1)*(vp(jc,ic)*br(jc,ic)-
+ $ vr(jc,ic)*bp(jc,ic))
+ bnlr3(jc,ic)=qk(kc,4)*qi(ic,1)*(vr(jc,ic)*bt(jc,ic)-
+ $ vt(jc,ic)*br(jc,ic))
+ enddo
+ enddo
+c
+ do 208 jc=nja+1,nja+2
+ do 209 ic=1,ni
+ wnlr1(jc,ic)=0.
+ wnlr2(jc,ic)=0.
+ wnlr3(jc,ic)=0.
+ snlr1(jc,ic)=0.
+ snlr2(jc,ic)=0.
+ snlr3(jc,ic)=0.
+ bnlr1(jc,ic)=0.
+ bnlr2(jc,ic)=0.
+ bnlr3(jc,ic)=0.
+ 209 continue
+ 208 continue
+c
+c -fourier transform from (k,i,j) to (k,i,m)
+c
+ call fourtf(wnlr1,work,trigsf,ifaxf,1,nrp,nja,ni,-1)
+ call fourtf(wnlr2,work,trigsf,ifaxf,1,nrp,nja,ni,-1)
+ call fourtf(wnlr3,work,trigsf,ifaxf,1,nrp,nja,ni,-1)
+ call fourtf(snlr1,work,trigsf,ifaxf,1,nrp,nja,ni,-1)
+ call fourtf(snlr2,work,trigsf,ifaxf,1,nrp,nja,ni,-1)
+ call fourtf(snlr3,work,trigsf,ifaxf,1,nrp,nja,ni,-1)
+ call fourtf(bnlr1,work,trigsf,ifaxf,1,nrp,nja,ni,-1)
+ call fourtf(bnlr2,work,trigsf,ifaxf,1,nrp,nja,ni,-1)
+ call fourtf(bnlr3,work,trigsf,ifaxf,1,nrp,nja,ni,-1)
+c
+c -legendre transform from (k,i,m) to (k,l,m)
+c
+ do 212 lmp=1,nlmpa
+ flmw1(lmp)=0.
+ flmw2(lmp)=0.
+ flmw3(lmp)=0.
+ flms1(lmp)=0.
+ flms2(lmp)=0.
+ flms3(lmp)=0.
+ flmb1(lmp)=0.
+ flmb2(lmp)=0.
+ flmb3(lmp)=0.
+ 212 continue
+ do 213 ic=1,ni
+ do 214 lmp=1,nlmpa
+ mca=mcalmp(lmp)
+ flmw1(lmp)=flmw1(lmp)+wnlc1(mca,ic)*aleg2(lmp,ic)
+ flmw2(lmp)=flmw2(lmp)+wnlc2(mca,ic)*aleg2(lmp,ic)
+ flmw3(lmp)=flmw3(lmp)+wnlc3(mca,ic)*aleg2(lmp,ic)
+ flms1(lmp)=flms1(lmp)+snlc1(mca,ic)*aleg2(lmp,ic)
+ flms2(lmp)=flms2(lmp)+snlc2(mca,ic)*aleg2(lmp,ic)
+ flms3(lmp)=flms3(lmp)+snlc3(mca,ic)*aleg2(lmp,ic)
+ flmb1(lmp)=flmb1(lmp)+bnlc1(mca,ic)*aleg2(lmp,ic)
+ flmb2(lmp)=flmb2(lmp)+bnlc2(mca,ic)*aleg2(lmp,ic)
+ flmb3(lmp)=flmb3(lmp)+bnlc3(mca,ic)*aleg2(lmp,ic)
+ 214 continue
+ 213 continue
+c
+ dwdt(1,kc,jnel)=real(flmw1(1))*qk(kc,1)
+ dsdt(1,kc,jnel)=epsc0
+ flmks(1,kc)=flms1(1)
+ flmkb(1,kc)=0.
+c
+ do lm=2,nlma
+ lma1=min(lm+1,nlma)
+ lmp=lm+(mclm(lm)-1)/minc
+ dwdt(lm,kc,jnel)=
+ $ flmw1(lmp)*qk(kc,1)+
+ $ 2.*oek*qk(kc,3)*(2.*cmplx(0.,ql(lm,13))*dw(lm,kc)+
+ $ ql(lm,14)*z(lma1,kc)-ql(lm,15)*z(lm-1,kc))
+ dzdt(lm,kc,jnel)=
+ $ (ql(lm,7)*flmw3(lmp-1)-ql(lm,8)*flmw3(lmp+1)-
+ $ cmplx(0.0,ql(lm,10))*flmw2(lmp))+
+ $ 2.*oek*qk(kc,1)*
+ $ (cmplx(0.0,ql(lm,13))*z(lm,kc)+
+ $ ql(lm,16)*(2.*dw(lma1,kc)+
+ $ ql(lm,17)*qk(kc,3)*w(lma1,kc))+
+ $ ql(lm,18)*(2.*dw(lm-1,kc)-
+ $ ql(lm,19)*qk(kc,3)*w(lm-1,kc)))
+c
+ dpdt(lm,kc,jnel)=
+ $ (ql(lm,7)*flmw2(lmp-1)-ql(lm,8)*flmw2(lmp+1)+
+ $ cmplx(0.0,ql(lm,10))*flmw3(lmp))+
+ $ 2.*oek*qk(kc,1)*(-cmplx(0.0,ql(lm,13))
+ $ *(2.*dw(lm,kc)+ql(lm,20)*qk(kc,3)*w(lm,kc))+
+ $ ql(lm,16)*z(lma1,kc)+
+ $ ql(lm,18)*z(lm-1,kc))
+ dsdt(lm,kc,jnel)=-(ql(lm,7)*flms2(lmp-1)-ql(lm,8)*flms2(lmp+1)+
+ $ cmplx(0.0,ql(lm,10))*flms3(lmp))
+ flmks(lm,kc)=flms1(lmp)
+ dbdt(lm,kc,jnel)=
+ $ (ql(lm,7)*flmb3(lmp-1)-ql(lm,8)*flmb3(lmp+1)-
+ $ cmplx(0.0,ql(lm,10))*flmb2(lmp))
+ djdt(lm,kc,jnel)=ql(lm,3)*qk(kc,4)*flmb1(lmp)
+ flmkb(lm,kc)=(ql(lm,7)*flmb2(lmp-1)-
+ $ ql(lm,8)*flmb2(lmp+1)+
+ $ cmplx(0.0,ql(lm,10))*flmb3(lmp))*(r(kc)*r(kc))
+ enddo
+c
+ 200 continue
+c
+c -radial derivatives of nl terms
+c
+ call chebtf(lot,ns2,lot,nnp1,nps2,
+ $flmks,flmks,flmks,wsave,work,
+ $work(1,2),work(1,2),work(1,2),trigsc,ifaxc,k2k)
+ do 249 lm=1,nlma
+ dflmk(lm,nn)=0.
+ dflmk(lm,nn1)=float(nn1)*flmks(lm,nn)
+ 249 continue
+ do 240 n=nn2,1,-1
+ do 240 lm=1,nlma
+ dflmk(lm,n)=dflmk(lm,n+2)+float(2*n)*flmks(lm,n+1)
+ 240 continue
+ call chebtf(lot,ns2,lot,nnp1,nps2,
+ $dflmk,dflmk,dflmk,wsave,work,
+ $work(1,2),work(1,2),work(1,2),trigsc,ifaxc,k2k)
+ do 242 kc=1,nn
+ do 243 lm=1,nlma
+ dsdt(lm,kc,jnel)=dsdt(lm,kc,jnel)-
+ $ 2.*qk(kc,1)*dflmk(lm,kc)
+ 243 continue
+ 242 continue
+ call chebtf(lot,ns2,lot,nnp1,nps2,
+ $flmkb,flmkb,flmkb,wsave,work,
+ $work(1,2),work(1,2),work(1,2),trigsc,ifaxc,k2k)
+ do 219 lm=1,nlma
+ dflmk(lm,nn)=0.
+ dflmk(lm,nn1)=float(nn1)*flmkb(lm,nn)
+ 219 continue
+ do 220 n=nn2,1,-1
+ do 220 lm=1,nlma
+ dflmk(lm,n)=dflmk(lm,n+2)+float(2*n)*flmkb(lm,n+1)
+ 220 continue
+ call chebtf(lot,ns2,lot,nnp1,nps2,
+ $dflmk,dflmk,dflmk,wsave,work,
+ $work(1,2),work(1,2),work(1,2),trigsc,ifaxc,k2k)
+ do 222 kc=1,nn
+ do 223 lm=2,nlma
+ djdt(lm,kc,jnel)=djdt(lm,kc,jnel)+
+ $ 2.*qk(kc,1)*dflmk(lm,kc)
+ 223 continue
+ 222 continue
+c
+c -time-step check and change if needed
+c
+ if(lcour .gt. 0) then
+ dth=sqrt(dth2)
+ call dtchck(kstep,newdt,dt,dtnew,
+ $ dtmin,dtmax,dtr,dth,ifirst,kcour)
+ else
+ dtnew=dt
+ endif
+c
+ w2new=-dtnew/(2.*dt)
+ coex=(1.-alpha)/w2new
+c
+c **************************************
+c update magnetic field
+c **************************************
+c
+ if(ifbfrz) then
+c
+ call chebtf(lot,ns2,lot,nnp1,nps2,
+ $b,b,b,wsave,work,
+ $work(1,2),work(1,2),work(1,2),trigsc,ifaxc,k2k)
+ call chebtf(lot,ns2,lot,nnp1,nps2,
+ $aj,aj,aj,wsave,work,
+ $work(1,2),work(1,2),work(1,2),trigsc,ifaxc,k2k)
+c
+ else
+c
+ do 730 lm=2,nlaf
+ l=lm-1
+ do kc=1,nn
+ frl(kc)=
+ $ (w1*real(dbdt(lm,kc,jnel))+
+ $ w2*real(dbdt(lm,kc,inel)))+
+ $ oodt*ql(lm,3)*qk(kc,1)*real(b(lm,kc))
+ frl2(kc)=
+ $ (w1*real(djdt(lm,kc,jnel))+
+ $ w2*real(djdt(lm,kc,inel)))+
+ $ oodt*ql(lm,3)*qk(kc,1)*real(aj(lm,kc))
+ enddo
+ frl(1)=0.
+ frl(nn)=0.
+ if(kbotb .eq. 2) frl(nn1)=.0
+ frl2(1)=0.
+ frl2(nn)=0.
+ if(l.eq.2.and.imagcon.gt.0.and.imagcon.ne.12) then
+ frl2(nn)=bpeakbot
+ frl2( 1)=bpeaktop
+ endif
+ if(l.eq.1.and.imagcon.eq.12) then
+ frl2(nn)=bpeakbot
+ frl2( 1)=bpeaktop
+ endif
+ if(l.eq.1.and.imagcon.lt. 0) frl(nn)= bpeakbot
+ call sgesl(bmat(1,1,l),nn,nn,ib(1,l),frl,0)
+ call sgesl(ajmat(1,1,l),nn,nn,ij(1,l),frl2,0)
+c
+ do nc=1,nnaf
+ b(lm,nc)=frl(nc)*bscl
+ aj(lm,nc)=frl2(nc)*bscl
+ enddo
+ 730 continue
+ do 731 lm=nlaf+1,nlma
+ l=nint(ql(lm,4))
+ do kc=1,nn
+ frl(kc)=
+ $ (w1*real(dbdt(lm,kc,jnel))+
+ $ w2*real(dbdt(lm,kc,inel)))+
+ $ oodt*ql(lm,3)*qk(kc,1)*real(b(lm,kc))
+ fim(kc)=
+ $ (w1*aimag(dbdt(lm,kc,jnel))+
+ $ w2*aimag(dbdt(lm,kc,inel)))+
+ $ oodt*ql(lm,3)*qk(kc,1)*aimag(b(lm,kc))
+ frl2(kc)=
+ $ (w1*real(djdt(lm,kc,jnel))+
+ $ w2*real(djdt(lm,kc,inel)))+
+ $ oodt*ql(lm,3)*qk(kc,1)*real(aj(lm,kc))
+ fim2(kc)=
+ $ (w1*aimag(djdt(lm,kc,jnel))+
+ $ w2*aimag(djdt(lm,kc,inel)))+
+ $ oodt*ql(lm,3)*qk(kc,1)*aimag(aj(lm,kc))
+ enddo
+ frl(1)=0.
+ fim(1)=0.
+ frl(nn)=0.
+ fim(nn)=0.
+ if(kbotb .eq. 2) then
+ frl(nn1)=0.
+ fim(nn1)=0.
+ endif
+ frl2(1)=0.
+ fim2(1)=0.
+ frl2(nn)=0.
+ fim2(nn)=0.
+ call sgesl(bmat(1,1,l),nn,nn,ib(1,l),frl,0)
+ call sgesl(bmat(1,1,l),nn,nn,ib(1,l),fim,0)
+ call sgesl(ajmat(1,1,l),nn,nn,ij(1,l),frl2,0)
+ call sgesl(ajmat(1,1,l),nn,nn,ij(1,l),fim2,0)
+ do nc=1,nnaf
+ b(lm,nc)=cmplx(frl(nc),fim(nc))*bscl
+ aj(lm,nc)=cmplx(frl2(nc),fim2(nc))*bscl
+ enddo
+ 731 continue
+ if(nnaf .lt. nn) then
+ do nc=nnaf+1,nn
+ do lm=2,nlma
+ b(lm,nc)=0.
+ aj(lm,nc)=0.
+ enddo
+ enddo
+ endif
+c
+ endif
+c
+c -radial derivs of b and j
+c
+ do lm=1,nlma
+ db(lm,nn)=0.
+ db(lm,nn1)=float(nn1)*b(lm,nn)
+ dj(lm,nn)=0.
+ dj(lm,nn1)=float(nn1)*aj(lm,nn)
+ ddb(lm,nn)=0.
+ ddb(lm,nn1)=0.
+ ddj(lm,nn)=0.
+ ddj(lm,nn1)=0.
+ enddo
+ do n=nn2,1,-1
+ do lm=1,nlma
+ db(lm,n)=db(lm,n+2)+float(2*n)*b(lm,n+1)
+ dj(lm,n)=dj(lm,n+2)+float(2*n)*aj(lm,n+1)
+ ddb(lm,n)=ddb(lm,n+2)+float(2*n)*db(lm,n+1)
+ ddj(lm,n)=ddj(lm,n+2)+float(2*n)*dj(lm,n+1)
+ enddo
+ enddo
+c
+c -chebyshev transform b, j and derivs from (n,l,m) to (k,l,m)
+c
+ call chebtf(lot,ns2,lot,nnp1,nps2,
+ $b,b,b,wsave,work,
+ $work(1,2),work(1,2),work(1,2),trigsc,ifaxc,k2k)
+ call chebtf(lot,ns2,lot,nnp1,nps2,
+ $db,db,db,wsave,work,
+ $work(1,2),work(1,2),work(1,2),trigsc,ifaxc,k2k)
+ call chebtf(lot,ns2,lot,nnp1,nps2,
+ $ddb,ddb,ddb,wsave,work,
+ $work(1,2),work(1,2),work(1,2),trigsc,ifaxc,k2k)
+ call chebtf(lot,ns2,lot,nnp1,nps2,
+ $aj,aj,aj,wsave,work,
+ $work(1,2),work(1,2),work(1,2),trigsc,ifaxc,k2k)
+ call chebtf(lot,ns2,lot,nnp1,nps2,
+ $dj,dj,dj,wsave,work,
+ $work(1,2),work(1,2),work(1,2),trigsc,ifaxc,k2k)
+ call chebtf(lot,ns2,lot,nnp1,nps2,
+ $ddj,ddj,ddj,wsave,work,
+ $work(1,2),work(1,2),work(1,2),trigsc,ifaxc,k2k)
+ do 755 kc=1,nnp1
+ b(1,kc)=0.
+ db(1,kc)=0.
+ ddb(1,kc)=0.
+ aj(1,kc)=0.
+ dj(1,kc)=0.
+ ddj(1,kc)=0.
+ 755 continue
+c
+c -explicit parts of the linear terms in the b and j equations
+c
+ if(alpha .lt. 1.) then
+ do 750 kc=1,nn
+ do 751 lm=2,nlma
+ dbdt(lm,kc,jnel)=dbdt(lm,kc,jnel)+coex*
+ $ ql(lm,11)*opm*qk(kc,1)*(4.*ddb(lm,kc)-
+ $ ql(lm,3)*qk(kc,1)*b(lm,kc))
+ djdt(lm,kc,jnel)=djdt(lm,kc,jnel)+coex*
+ $ ql(lm,11)*opm*qk(kc,1)*(4.*ddj(lm,kc)-
+ $ ql(lm,3)*qk(kc,1)*aj(lm,kc))
+ 751 continue
+ 750 continue
+ endif
+c
+c **************************************
+c update entropy
+c **************************************
+c
+ if(ifsfrz) then
+c
+ call chebtf(lot,ns2,lot,nnp1,nps2,
+ $s,s,s,wsave,work,
+ $work(1,2),work(1,2),work(1,2),trigsc,ifaxc,k2k)
+c
+ else
+c
+ do kc=1,nn
+ frl(kc)=real(s(1,kc))*oodt+
+ $ (w1*real(dsdt(1,kc,jnel))+
+ $ w2*real(dsdt(1,kc,inel)))
+ enddo
+ frl(1)=real(tops(0,0))
+ frl(nn)=real(bots(0,0))
+ call sgesl(s0mat,nn,nn,is0,frl,0)
+ do nc=1,nnaf
+ s(1,nc)=frl(nc)*sscl
+ enddo
+ do 530 lm=2,nlaf
+ l=lm-1
+ do kc=1,nn
+ frl(kc)=real(s(lm,kc))*oodt+
+ $ (w1*real(dsdt(lm,kc,jnel))+
+ $ w2*real(dsdt(lm,kc,inel)))
+ enddo
+ frl(1)=real(tops(l,0))
+ frl(nn)=real(bots(l,0))
+ call sgesl(smat(1,1,l),nn,nn,is(1,l),frl,0)
+ do nc=1,nnaf
+ s(lm,nc)=frl(nc)*sscl
+ enddo
+ 530 continue
+ do 531 lm=nlaf+1,nlma
+ l=nint(ql(lm,4))
+ m=mclm(lm)-1
+ do kc=1,nn
+ frl(kc)=real(s(lm,kc))*oodt+
+ $ (w1*real(dsdt(lm,kc,jnel))+
+ $ w2*real(dsdt(lm,kc,inel)))
+ fim(kc)=aimag(s(lm,kc))*oodt+
+ $ (w1*aimag(dsdt(lm,kc,jnel))+
+ $ w2*aimag(dsdt(lm,kc,inel)))
+ enddo
+ frl(1)=real(tops(l,m))
+ frl(nn)=real(bots(l,m))
+ fim(1)=aimag(tops(l,m))
+ fim(nn)=aimag(bots(l,m))
+ call sgesl(smat(1,1,l),nn,nn,is(1,l),frl,0)
+ call sgesl(smat(1,1,l),nn,nn,is(1,l),fim,0)
+ do nc=1,nnaf
+ s(lm,nc)=cmplx(frl(nc),fim(nc))*sscl
+ enddo
+ 531 continue
+ if(nnaf .lt. nn) then
+ do nc=nnaf+1,nn
+ do lm=1,nlma
+ s(lm,nc)=0.
+ enddo
+ enddo
+ endif
+c
+ endif
+c
+c *** radial derivs of s
+c
+ do lm=1,nlma
+ ds(lm,nn)=0.
+ ds(lm,nn1)=float(nn1)*s(lm,nn)
+ dds(lm,nn)=0.
+ dds(lm,nn1)=0.
+ enddo
+ do n=nn2,1,-1
+ do lm=1,nlma
+ ds(lm,n)=ds(lm,n+2)+float(2*n)*s(lm,n+1)
+ dds(lm,n)=dds(lm,n+2)+float(2*n)*ds(lm,n+1)
+ enddo
+ enddo
+c
+c *** chebyshev transform s and derivs from (n,l,m) to (k,l,m)
+c
+ call chebtf(lot,ns2,lot,nnp1,nps2,
+ $s,s,s,wsave,work,
+ $work(1,2),work(1,2),work(1,2),trigsc,ifaxc,k2k)
+ call chebtf(lot,ns2,lot,nnp1,nps2,
+ $ds,ds,ds,wsave,work,
+ $work(1,2),work(1,2),work(1,2),trigsc,ifaxc,k2k)
+ call chebtf(lot,ns2,lot,nnp1,nps2,
+ $dds,dds,dds,wsave,work,
+ $work(1,2),work(1,2),work(1,2),trigsc,ifaxc,k2k)
+c
+c -explicit parts of the linear terms in the s equation
+c
+ if(alpha .lt. 1.) then
+ do 545 kc=1,nn
+ do 546 lm=1,nlma
+ dsdt(lm,kc,jnel)=dsdt(lm,kc,jnel)+coex*
+ $ opr*(4.*dds(lm,kc)+
+ $ qk(kc,2)*ds(lm,kc)-ql(lm,3)*qk(kc,1)*s(lm,kc))
+ 546 continue
+ 545 continue
+ endif
+c
+c *********************************************************
+c -diagnostics
+c *********************************************************
+c
+c urc modified
+ if(mod(kstep,nlogstep).eq.0.or.kel.eq.2) then
+ botlum=-4.*pi*y00*r(nn)**2*opr*
+ $ (2.*real(ds(1,nn)))
+ toplum=-4.*pi*y00*r(1)**2*opr*
+ $ (2.*real(ds(1,1)))
+ endif
+c
+c ***************************************
+c update velocity and pressure
+c ***************************************
+c
+ if(ifvfrz) then
+c
+ call chebtf(lot,ns2,lot,nnp1,nps2,
+ $w,w,w,wsave,work,
+ $work(1,2),work(1,2),work(1,2),trigsc,ifaxc,k2k)
+ call chebtf(lot,ns2,lot,nnp1,nps2,
+ $z,z,z,wsave,work,
+ $work(1,2),work(1,2),work(1,2),trigsc,ifaxc,k2k)
+ call chebtf(lot,ns2,lot,nnp1,nps2,
+ $p,p,p,wsave,work,
+ $work(1,2),work(1,2),work(1,2),trigsc,ifaxc,k2k)
+c
+ else
+c
+ do 630 lm=2,nlaf
+ l=lm-1
+ do kc=1,nn
+ frl(kc)=oodt*ql(lm,3)*qk(kc,1)*real(z(lm,kc))+
+ $ (w1*real(dzdt(lm,kc,jnel))+
+ $ w2*real(dzdt(lm,kc,inel)))
+ frl2(kc)=(oodt*ql(lm,3)*qk(kc,1)*real(w(lm,kc))+
+ $ (rapr*alpha*grav(kc)*real(s(lm,kc))+
+ $ (w1*real(dwdt(lm,kc,jnel))+
+ $ w2*real(dwdt(lm,kc,inel)))))
+ frl2(kc+nn)=-oodt*ql(lm,3)*qk(kc,1)*
+ $ (2.*real(dw(lm,kc)))+
+ $ (w1*real(dpdt(lm,kc,jnel))+
+ $ w2*real(dpdt(lm,kc,inel)))
+ enddo
+ frl(1)=0.
+ frl(nn)=0.
+ frl2(1)=0.
+ frl2(nn)=0.
+ frl2(nnp1)=0.
+ frl2(nnx2)=0.
+ call sgesl(zmat(1,1,l),nn,nn,iz(1,l),frl,0)
+ call sgesl(wpmat(1,1,l),nnx2,nnx2,iwp(1,l),frl2,0)
+ do nc=1,nnaf
+ z(lm,nc)=frl(nc)*zscl
+ w(lm,nc)=frl2(nc)*wscl
+ p(lm,nc)=frl2(nc+nn)*pscl
+ enddo
+ 630 continue
+ do 631 lm=nlaf+1,nlma
+ l=nint(ql(lm,4))
+ do kc=1,nn
+ frl(kc)=oodt*ql(lm,3)*qk(kc,1)*real(z(lm,kc))+
+ $ (w1*real(dzdt(lm,kc,jnel))+
+ $ w2*real(dzdt(lm,kc,inel)))
+ frl2(kc)=(oodt*ql(lm,3)*qk(kc,1)*real(w(lm,kc))+
+ $ (rapr*alpha*grav(kc)*real(s(lm,kc))+
+ $ (w1*real(dwdt(lm,kc,jnel))+
+ $ w2*real(dwdt(lm,kc,inel)))))
+ frl2(kc+nn)=-oodt*ql(lm,3)*qk(kc,1)*
+ $ (2.*real(dw(lm,kc)))+
+ $ (w1*real(dpdt(lm,kc,jnel))+
+ $ w2*real(dpdt(lm,kc,inel)))
+ fim(kc)=oodt*ql(lm,3)*qk(kc,1)*aimag(z(lm,kc))+
+ $ (w1*aimag(dzdt(lm,kc,jnel))+
+ $ w2*aimag(dzdt(lm,kc,inel)))
+ fim2(kc)=(oodt*ql(lm,3)*qk(kc,1)*aimag(w(lm,kc))+
+ $ (rapr*alpha*grav(kc)*aimag(s(lm,kc))+
+ $ (w1*aimag(dwdt(lm,kc,jnel))+
+ $ w2*aimag(dwdt(lm,kc,inel)))))
+ fim2(kc+nn)=-oodt*ql(lm,3)*qk(kc,1)*
+ $ (2.*aimag(dw(lm,kc)))+
+ $ (w1*aimag(dpdt(lm,kc,jnel))+
+ $ w2*aimag(dpdt(lm,kc,inel)))
+ enddo
+ frl(1)=0.
+ frl(nn)=0.
+ frl2(1)=0.
+ frl2(nn)=0.
+ frl2(nnp1)=0.
+ frl2(nnx2)=0.
+ fim(1)=0.
+ fim(nn)=0.
+ fim2(1)=0.
+ fim2(nn)=0.
+ fim2(nnp1)=0.
+ fim2(nnx2)=0.
+ call sgesl(zmat(1,1,l),nn,nn,iz(1,l),frl,0)
+ call sgesl(zmat(1,1,l),nn,nn,iz(1,l),fim,0)
+ call sgesl(wpmat(1,1,l),nnx2,nnx2,iwp(1,l),frl2,0)
+ call sgesl(wpmat(1,1,l),nnx2,nnx2,iwp(1,l),fim2,0)
+ do nc=1,nnaf
+ z(lm,nc)=cmplx(frl(nc),fim(nc))*zscl
+ w(lm,nc)=cmplx(frl2(nc),fim2(nc))*wscl
+ p(lm,nc)=cmplx(frl2(nc+nn),fim2(nc+nn))*pscl
+ enddo
+ 631 continue
+ if(nnaf .lt. nn) then
+ do nc=nnaf+1,nn
+ do lm=2,nlma
+ z(lm,nc)=0.
+ w(lm,nc)=0.
+ p(lm,nc)=0.
+ enddo
+ enddo
+ endif
+c
+ endif
+c
+c -radial derivs of w and z
+c
+ do lm=1,nlma
+ dw(lm,nn)=0.
+ dw(lm,nn1)=float(nn1)*w(lm,nn)
+ ddw(lm,nn)=0.
+ ddw(lm,nn1)=0.
+ dddw(lm,nn)=0.
+ dddw(lm,nn1)=0.
+ dz(lm,nn)=0.
+ dz(lm,nn1)=float(nn1)*z(lm,nn)
+ ddz(lm,nn)=0.
+ ddz(lm,nn1)=0.
+ end do
+ do n=nn2,1,-1
+ do lm=1,nlma
+ dw(lm,n)=dw(lm,n+2)+float(2*n)*w(lm,n+1)
+ ddw(lm,n)=ddw(lm,n+2)+float(2*n)*dw(lm,n+1)
+ dddw(lm,n)=dddw(lm,n+2)+float(2*n)*ddw(lm,n+1)
+ dz(lm,n)=dz(lm,n+2)+float(2*n)*z(lm,n+1)
+ ddz(lm,n)=ddz(lm,n+2)+float(2*n)*dz(lm,n+1)
+ end do
+ end do
+c
+c -chebyshev transform w, z and derivs from (n,l,m) to (k,l,m)
+c
+ call chebtf(lot,ns2,lot,nnp1,nps2,
+ $w,w,w,wsave,work,
+ $work(1,2),work(1,2),work(1,2),trigsc,ifaxc,k2k)
+ call chebtf(lot,ns2,lot,nnp1,nps2,
+ $dw,dw,dw,wsave,work,
+ $work(1,2),work(1,2),work(1,2),trigsc,ifaxc,k2k)
+ call chebtf(lot,ns2,lot,nnp1,nps2,
+ $ddw,ddw,ddw,wsave,work,
+ $work(1,2),work(1,2),work(1,2),trigsc,ifaxc,k2k)
+ call chebtf(lot,ns2,lot,nnp1,nps2,
+ $dddw,dddw,dddw,wsave,work,
+ $work(1,2),work(1,2),work(1,2),trigsc,ifaxc,k2k)
+ call chebtf(lot,ns2,lot,nnp1,nps2,
+ $z,z,z,wsave,work,
+ $work(1,2),work(1,2),work(1,2),trigsc,ifaxc,k2k)
+ call chebtf(lot,ns2,lot,nnp1,nps2,
+ $dz,dz,dz,wsave,work,
+ $work(1,2),work(1,2),work(1,2),trigsc,ifaxc,k2k)
+ call chebtf(lot,ns2,lot,nnp1,nps2,
+ $ddz,ddz,ddz,wsave,work,
+ $work(1,2),work(1,2),work(1,2),trigsc,ifaxc,k2k)
+ do kc=1,nnp1
+ w(1,kc)=0.
+ dw(1,kc)=0.
+ ddw(1,kc)=0.
+ dddw(1,kc)=0.
+ z(1,kc)=0.
+ dz(1,kc)=0.
+ ddz(1,kc)=0.
+ end do
+c
+c -update the l=0 part of pressure
+c
+ if(.not. ifvfrz) then
+c
+ do 652 kc=1,nn
+ frl(kc)=real(dwdt(1,kc,jnel))+
+ $ rapr*grav(kc)*real(s(1,kc))+
+ $ oek*p00co*qk(kc,3)*real(z(2,kc))
+ 652 continue
+ frl(nps2)=0.
+c
+ call sgesl(p0mat,nn,nn,ip0,frl,0)
+ do 653 nc=1,nnaf
+ p(1,nc)=frl(nc)
+ 653 continue
+ if(nnaf .lt. nn) then
+ do 654 nc=nnaf+1,nn
+ p(1,nc)=0.
+ 654 continue
+ endif
+c
+ endif
+c
+c -radial derivs of p
+c
+ do lm=1,nlma
+ dp(lm,nn)=0.
+ dp(lm,nn1)=float(nn1)*p(lm,nn)
+ end do
+ do n=nn2,1,-1
+ do lm=1,nlma
+ dp(lm,n)=dp(lm,n+2)+float(2*n)*p(lm,n+1)
+ end do
+ end do
+c
+c -chebyshev transform p and derivs from (n,l,m) to (k,l,m)
+c
+ call chebtf(lot,ns2,lot,nnp1,nps2,
+ $p,p,p,wsave,work,
+ $work(1,2),work(1,2),work(1,2),trigsc,ifaxc,k2k)
+ call chebtf(lot,ns2,lot,nnp1,nps2,
+ $dp,dp,dp,wsave,work,
+ $work(1,2),work(1,2),work(1,2),trigsc,ifaxc,k2k)
+c
+c -explicit parts of the linear terms in the w and z equations
+c
+ if(alpha .lt. 1.) then
+ do kc=1,nn
+ do lm=2,nlma
+ dwdt(lm,kc,jnel)=dwdt(lm,kc,jnel)+coex*
+ $ (-2.*dp(lm,kc)+
+ $ rapr*grav(kc)*s(lm,kc)+
+ $ ql(lm,12)*qk(kc,1)*
+ $ (4.*ddw(lm,kc)-
+ $ (ql(lm,3)*qk(kc,1))*w(lm,kc)))
+ dpdt(lm,kc,jnel)=dpdt(lm,kc,jnel)+coex*
+ $ (ql(lm,3)*qk(kc,1)*p(lm,kc)+
+ $ ql(lm,12)*qk(kc,1)*
+ $ (-8.*dddw(lm,kc)+
+ $ 2.*(ql(lm,3)*qk(kc,1))*dw(lm,kc)-
+ $ ql(lm,3)*qk(kc,5)*w(lm,kc)))
+ dzdt(lm,kc,jnel)=dzdt(lm,kc,jnel)+coex*
+ $ ql(lm,12)*qk(kc,1)*
+ $ (4.*ddz(lm,kc)-
+ $ (ql(lm,3)*qk(kc,1))*z(lm,kc))
+ enddo
+ enddo
+ endif
+c
+c -energies
+c
+c urc: distinguish between energy in toroidal and poloidal fields
+ call kei(envp,envt,adrke,amcke)
+ env=envp+envt
+ call mei(enbp,enbt,apome,atome)
+ enb=enbp+enbt
+ ent=env+enb
+c urc: log-file with energy components written
+c
+ topnuss=toplum/alum0
+ botnuss=botlum/alum0
+ if(mod(kstep,nlogstep).eq.0) write(15,'(f9.6,8f9.2,2f9.5)')
+ $time/tscale,env/escale,envp/escale,enb/escale,enbp/escale,
+ $adrke/escale,amcke/escale,apome/escale,atome/escale,
+ $topnuss,botnuss
+ if(nplog.gt.0) then
+ if(mod(kstep,nplog).eq.0) write(17,'(f9.6,6(1x,f9.3))')
+ $ time/tscale,
+ $ vrpoint(nn/2),vppoint(nn/2),
+ $ vrpoint(2*nn/3),vppoint(2*nn/3)
+ endif
+c
+c -change time-step
+c
+ dt=dtnew
+ oodt=1./dt
+c
+ 1002 continue
+c
+c ***** end of explicit loop: 1001 continue
+ if(istep.lt.nstep) go to 100
+c
+ 1000 continue
+c
+c
+ vmax=sqrt(vmax)/vscale
+ vmean=sqrt(2.*env/ocorevol)/vscale
+c urc+2
+ bmax=sqrt(bmax)
+ bmean=sqrt(2.*enb/(ocorevol*oekpm))
+ dth=sqrt(dth2)
+ write(6,900) kstep,time/tscale
+ 900 format(/4x,"****",i6,1x,"steps",3x,
+ $"time=",3x,f9.6," (visc.diff.time) ****")
+ write(6,901) dt/tscale,dtr/tscale,dth/tscale
+ 901 format(/,2x,"dt =",f10.8,3x,"dtrmin =",f10.8,3x,
+ $"dthmin =",f10.8)
+ write(6,911) courmax*tscale,kcrmax,couhmax*tscale,
+ $ kchmax,alfrmax*tscale,karmax,alfhmax*tscale,kahmax
+ 911 format(2x,"cour= ",f7.0,i4," couh= ",f7.0,i4,
+ $ " alfr= ",f7.0,i4," alfh= ",f7.0,i4)
+ write(6,902) ent/escale,env/escale,enb/escale
+ 902 format(2x,"ent = ",1pe10.3,1x,"env =",1pe10.3,1x,
+ $"enb =",1pe10.3)
+ write(6,907) vmax,vmean
+ 907 format(2x,"max/mean velocity =",f9.3,1x,f9.3)
+ write(6,904) bmax,bmean
+ 904 format(2x,"max/mean field =",f9.4,1x,f9.4)
+c diflum=toplum-botlum
+c write(6,905) botlum,toplum,diflum
+c 905 format(2x,"botlum =",1pe9.2,3x,"toplum =",1pe9.2,
+c $3x,"top-bot =",1pe9.2," ergs/s")
+c urc + 7
+ topnusselt=toplum/alum0
+ botnusselt=botlum/alum0
+ write(6,909) topnusselt,botnusselt
+ 909 format(2x,"nusselt number top/bot =",2(1X,f8.5))
+c
+c -print w, z, s, p, b, aj
+c
+ call prnt
+c
+c -store current solution
+c note, this gets overwritten until istor increases
+c
+ if(ngform.gt.-1) call stor
+ call spectrum(0)
+ call spectrum(1)
+c
+c -stop if dt too small
+c
+ if(dtmin .eq. 0.) stop '23'
+c
+ return
+ end
Added: 3D/MAG/trunk/src/cftrig.f
===================================================================
--- 3D/MAG/trunk/src/cftrig.f 2006-06-26 21:27:17 UTC (rev 3892)
+++ 3D/MAG/trunk/src/cftrig.f 2006-06-27 00:20:45 UTC (rev 3893)
@@ -0,0 +1,15 @@
+ subroutine cftrig(n,trigs)
+c
+c called in chebi
+c
+ dimension trigs(*)
+ pi=2.0*asin(1.0)
+ del=(pi+pi)/float(n)
+ l=n+n
+ do 10 i=1,l,2
+ angle=0.5*float(i-1)*del
+ trigs(i)=cos(angle)
+ trigs(i+1)=sin(angle)
+ 10 continue
+ return
+ end
Added: 3D/MAG/trunk/src/chebi.f
===================================================================
--- 3D/MAG/trunk/src/chebi.f 2006-06-26 21:27:17 UTC (rev 3892)
+++ 3D/MAG/trunk/src/chebi.f 2006-06-27 00:20:45 UTC (rev 3893)
@@ -0,0 +1,43 @@
+ subroutine chebi(n,wsave,trigs,ifax,k2k)
+c
+c initialization for sub chebtf
+c
+c called in prep
+c
+ dimension wsave(*),trigs(*),ifax(*),k2k(*)
+c
+ if(n .le. 3) stop '41'
+ nm1=n-1
+ if(mod(nm1,4) .ne. 0) stop '42'
+ np1=n+1
+ ns2 = nm1/2
+ ns2m = ns2-1
+ iw1 = ns2+1
+ nm2=n-2
+ k2k(1)=1
+ k2k(2)=2
+c
+ do 10 k=3,nm2,2
+ k2k(k)=np1-k
+ k2k(k+1)=k2k(k)+1
+ 10 continue
+c
+ pi = 4.*atan(1.)
+ dt = pi/float(nm1)
+ dcs = cos(dt)
+ dss = sin(dt)
+ wsave(1) = dss+dss
+ wck = dcs+dcs
+ if (ns2m .lt. 2) go to 102
+ do 101 k=2,ns2m
+ wsave(k) = dss*wck+dcs*wsave(k-1)
+ wck = dcs*wck-dss*wsave(k-1)
+ 101 continue
+ 102 call rffti (nm1,wsave(iw1))
+ call fact(ns2,ifax)
+ k=ifax(1)
+ if((k .lt. 1) .or. (ifax(k+1) .gt. 5)) stop '43'
+ call cftrig(ns2,trigs)
+c
+ return
+ end
Added: 3D/MAG/trunk/src/chebtf.f
===================================================================
--- 3D/MAG/trunk/src/chebtf.f 2006-06-26 21:27:17 UTC (rev 3892)
+++ 3D/MAG/trunk/src/chebtf.f 2006-06-27 00:20:45 UTC (rev 3893)
@@ -0,0 +1,188 @@
+ subroutine chebtf(lot,ns2,jmp1,jmp2,js2,x,x3,xh,wsave,
+ $work,x2,xh1,xh2,trigs,ifax,k2k)
+c
+c performs multiple fast chebyshev transforms
+c
+c called in amhd, prep, keimei, spectrum
+c
+c
+c x(l,k) = sqrt(2/nm1) * sum(j=0 to nm1) of x(l,j) * cheb(j,k)
+c with the j=0 and nm1 terms multiplied by 1/2,
+c where cheb(j,k)=cos(pi*j*k/nm1)
+c
+c chebtf is the normalized inverse of itself
+c
+c sub chebi must be called once to initialize wsave, trigs, ifax, k2k
+c these three and n must not be changed
+c
+c n = nm1+1 = 2*ns2+1 = length of the vectors to be tranformed
+c n must be odd and .gt. 3
+c nm1 must be divisible by 4
+c
+c lot is the number of vectors to be tranformed
+c
+c jmp1 is the first dim of x and is .ge. lot
+c
+c jmp2 = (2*js2) is the first dim of x2 and x3 and is .ge. (2*ns2)
+c and should not be a multiple of 8 on the cray
+c but must be a multiple of 2
+c
+c real x(jmp1,jmp2/n),wsave(n),work(jmp1,jmp2+1),trigs(n),ifax(13),k2k(nm1)
+c note x2,xh1,xh2 are equivalenced with w(1,2)
+c and x3 and xh are equivalenced with x
+c
+c if array x is complex x(nlm,n) then jmp1=2*nlm
+c
+ dimension x(jmp1,*),wsave(*),work(jmp1,*),trigs(*),ifax(*),k2k(*),
+ $x2(jmp2,jmp1),x3(jmp2,jmp1),xh(jmp1,2,*),xh1(2,js2,jmp1),
+ $xh2(jmp1,2,js2)
+c
+ if(2*js2 .ne. jmp2) stop '40'
+ nm1=2*ns2
+ n=nm1+1
+ np1=n+1
+ ns2m1=ns2-1
+ ns2p1=ns2+1
+ ns2p2=ns2+2
+ nq=ns2/2
+ nqp1=nq+1
+ nfax=ifax(1)
+ la=1
+ igo=110
+ i02=2
+ con=sqrt(1./(8.*float(nm1)))
+c
+ do 10 l=1,lot
+ work(l,1)=x(l,1)-x(l,n)
+ 10 continue
+c
+ do 102 k=2,ns2
+ k1=np1-k
+ k2=ns2p1-k
+ do 102 l=1,lot
+ work(l,1)=work(l,1)+wsave(k2)*(x(l,k)-x(l,k1))
+ 102 continue
+c
+ k3=k2k(1)
+ k4=k2k(ns2p1)
+c
+ do 11 l=1,lot
+ work(l,1)=work(l,1)+work(l,1)
+ x2(k3,l)=x(l,1)+x(l,n)
+ x2(k4,l)=x(l,ns2p1)+x(l,ns2p1)
+ 11 continue
+c
+ do 103 k=2,ns2
+ k1=np1-k
+ k2=k-1
+ k3=k2k(k)
+ k4=k2k(k1)
+ do 103 l=1,lot
+ x2(k3,l)=x(l,k)+x(l,k1)-wsave(k2)*(x(l,k)-x(l,k1))
+ x2(k4,l)=x(l,k)+x(l,k1)+wsave(k2)*(x(l,k)-x(l,k1))
+ 103 continue
+c
+ if(mod(nfax,2) .eq. 0) go to 15
+ igo=120
+c
+ do 16 k=1,nm1
+ do 16 l=1,lot
+ x3(k,l)=x2(k,l)
+ 16 continue
+c
+ 15 continue
+c
+ do 140 k=1,nfax
+ if(igo .eq. 120) go to 120
+c
+ call vpassm(x2(1,1),x2(2,1),x3(1,1),x3(2,1),trigs,i02,i02,
+ $jmp2,jmp2,lot,ns2,ifax(k+1),la)
+c
+ igo=120
+ go to 130
+ 120 continue
+c
+ call vpassm(x3(1,1),x3(2,1),x2(1,1),x2(2,1),trigs,i02,i02,
+ $jmp2,jmp2,lot,ns2,ifax(k+1),la)
+c
+ igo=110
+ 130 continue
+ la=la*ifax(k+1)
+ 140 continue
+c
+ do 12 l=1,lot
+ xh(l,1,nqp1)=xh1(1,nqp1,l)+xh1(1,nqp1,l)
+ xh(l,2,nqp1)=xh1(2,nqp1,l)+xh1(2,nqp1,l)
+ xh(l,1,1)=xh1(1,1,l)+xh1(1,1,l)+xh1(2,1,l)+xh1(2,1,l)
+ xh(l,2,1)=xh1(1,1,l)+xh1(1,1,l)-xh1(2,1,l)-xh1(2,1,l)
+ 12 continue
+c
+ if(nq .lt. 2) go to 107
+c
+ do 101 k=2,nq
+ k1=ns2p2-k
+ do 101 l=1,lot
+ xh(l,1,k)=xh1(1,k,l)+xh1(1,k1,l)
+ xh(l,2,k)=xh1(2,k,l)-xh1(2,k1,l)
+ xh(l,1,k1)=xh1(2,k,l)+xh1(2,k1,l)
+ xh(l,2,k1)=xh1(1,k1,l)-xh1(1,k,l)
+ 101 continue
+c
+ do 100 k=2,nq
+ k1=ns2p2-k
+ k2=k+ns2m1
+ k3=k1+ns2m1
+ do 100 l=1,lot
+ xh2(l,1,k1)=wsave(k2)*xh(l,1,k1)+wsave(k3)*xh(l,2,k1)
+ xh2(l,2,k1)=wsave(k2)*xh(l,2,k1)-wsave(k3)*xh(l,1,k1)
+ 100 continue
+c
+ do 104 k=2,nq
+ k1=ns2p2-k
+ do 104 l=1,lot
+ xh(l,1,k1)=xh2(l,1,k1)
+ xh(l,2,k1)=xh2(l,2,k1)
+ 104 continue
+c
+ do 105 k=2,nq
+ k1=ns2p2-k
+ do 105 l=1,lot
+ xh2(l,1,k1)=xh(l,1,k)-xh(l,1,k1)
+ xh2(l,2,k1)=xh(l,2,k)-xh(l,2,k1)
+ xh2(l,1,k)=xh(l,1,k)+xh(l,1,k1)
+ xh2(l,2,k)=-xh(l,2,k)-xh(l,2,k1)
+ 105 continue
+c
+ 107 continue
+c
+ do 13 l=1,lot
+ xh2(l,1,1)=xh(l,1,1)
+ xh2(l,2,1)=xh(l,2,1)
+ xh2(l,1,nqp1)=xh(l,1,nqp1)
+ xh2(l,2,nqp1)=xh(l,2,nqp1)
+ 13 continue
+c
+ do 14 l=1,lot
+cc x(l,1)=work(l,2)*con
+cc x(l,2)=work(l,1)*con
+cc x(l,n)=work(l,3)*con
+c
+c message from Gary: if problem with optimizer (e.g. on T3E),
+c replace the previous 3 lines of code by the following 3 lines
+c
+ xh(l,1,1)=work(l,2)*con
+ xh(l,2,1)=work(l,1)*con
+ xh(l,n,1)=work(l,3)*con
+ 14 continue
+c
+ do 106 i=4,nm1,2
+ i1=i+1
+ i2=i-2
+ i3=i-1
+ do 106 l=1,lot
+ x(l,i3)=work(l,i)*con
+ x(l,i)=work(l,i1)*con+x(l,i2)
+ 106 continue
+c
+ return
+ end
Added: 3D/MAG/trunk/src/cmbcoeff.f
===================================================================
--- 3D/MAG/trunk/src/cmbcoeff.f 2006-06-26 21:27:17 UTC (rev 3892)
+++ 3D/MAG/trunk/src/cmbcoeff.f 2006-06-27 00:20:45 UTC (rev 3893)
@@ -0,0 +1,30 @@
+ subroutine cmbcoeff(kc)
+c
+c called in amhd
+c supplied by urc
+c
+c output of complex spherical harmonic coefficients
+c for the poloidal magnetic potential b at the outer
+c boundary and of the poloidal velocity potential w,
+c its radial derivative dw, and the toroidal velocity
+c potential z at the radial level kc
+c
+ include 'param.f'
+ include 'com1.f'
+ include 'com3.f'
+ include 'com5.f'
+ include 'com8.f'
+c
+c write header
+c
+ write(21) nlma,lmax,minc,r(1),r(kc),time/tscale
+c
+c write data
+c
+ write(21) (b(lm,1),lm=1,nlma)
+ write(21) (w(lm,kc),lm=1,nlma)
+ write(21) (dw(lm,kc),lm=1,nlma)
+ write(21) (z(lm,kc),lm=1,nlma)
+c
+ return
+ end
Added: 3D/MAG/trunk/src/com1.f
===================================================================
--- 3D/MAG/trunk/src/com1.f 2006-06-26 21:27:17 UTC (rev 3892)
+++ 3D/MAG/trunk/src/com1.f 2006-06-27 00:20:45 UTC (rev 3893)
@@ -0,0 +1,3 @@
+ common /com1/ rva(nn),rvap(nn),rvat(nn),rvb(nn),rvc(nn),
+ $r(nn),grav(nn),ocorevol,radratio,radtop,radbot,
+ $ra,pr,opr,prmag,opm,ek,oek,oekpm,rapr,epsc0
Added: 3D/MAG/trunk/src/com2.f
===================================================================
--- 3D/MAG/trunk/src/com2.f 2006-06-26 21:27:17 UTC (rev 3892)
+++ 3D/MAG/trunk/src/com2.f 2006-06-27 00:20:45 UTC (rev 3893)
@@ -0,0 +1,4 @@
+ common /com2/ p0mat(nn,nn),s0mat(nn,nn),
+ $smat(nn,nn,lmax),zmat(nn,nn,lmax),wpmat(nnx2,nnx2,lmax),
+ $bmat(nn,nn,lmax),ajmat(nn,nn,lmax),ib(nn,lmax),ij(nn,lmax),
+ $ip0(nn),is0(nn),is(nn,lmax),iz(nn,lmax),iwp(nnx2,lmax)
Added: 3D/MAG/trunk/src/com3.f
===================================================================
--- 3D/MAG/trunk/src/com3.f 2006-06-26 21:27:17 UTC (rev 3892)
+++ 3D/MAG/trunk/src/com3.f 2006-06-27 00:20:45 UTC (rev 3893)
@@ -0,0 +1,12 @@
+ common /com3/ time,dt,oodt,dtmin,dtmax,dtold,
+ $dtstart,env,enb,dtr,dth,alpha,courfac,alffac,tipdipole,dipfilt,
+ $alfilt,
+ $init,kstep,nstep,iprnt,nprnt,istor,nstor,nlogstep,nplog,
+ $iscale,ifirst,icour,kcour,imagcon,nfilt,ivfilt,
+ $ktops,kbots,ktopv,kbotv,ktopb,kbotb,ifvfrz,ifbfrz,ifsfrz
+c
+ logical ifvfrz,ifbfrz,ifsfrz
+c
+ common /com31/ outfile,rstfile
+c
+ character*72 rstfile,outfile
Added: 3D/MAG/trunk/src/com4.f
===================================================================
--- 3D/MAG/trunk/src/com4.f 2006-06-26 21:27:17 UTC (rev 3892)
+++ 3D/MAG/trunk/src/com4.f 2006-06-27 00:20:45 UTC (rev 3893)
@@ -0,0 +1,11 @@
+ common /com4/ ai,tops(0:lmax,0:mmax),bots(0:lmax,0:mmax),
+ $qi(ni,5),qk(nn,6),ql(nlma,20),qn(nn,6),
+ $aleg1(nlma,ni),aleg2(nlmpa,ni),aleg3(nlma,ni),
+ $trigsc(nn),trigsf(ntf),wsave(nn),delxr(nn),delxh2(nn),
+ $work(lot,nnp2),bpeak,bpeakbot,bpeaktop,
+ $wscl,zscl,pscl,sscl,oosscl,bscl,
+ $cmb,pi,y00,p00co,anorm,
+ $mclm(nlma),mcalmp(nlmpa),mclma(nlma),
+ $ifaxc(13),ifaxf(13),k2k(nn1)
+c
+ complex ai,tops,bots
Added: 3D/MAG/trunk/src/com5.f
===================================================================
--- 3D/MAG/trunk/src/com5.f 2006-06-26 21:27:17 UTC (rev 3892)
+++ 3D/MAG/trunk/src/com5.f 2006-06-27 00:20:45 UTC (rev 3893)
@@ -0,0 +1,22 @@
+ common /com51/ w(nlma,nnp1),z(nlma,nnp1)
+ common /com52/ s(nlma,nnp1),p(nlma,nnp1)
+ common /com53/ dw(nlma,nnp1),ddw(nlma,nnp1),dddw(nlma,nnp1)
+ $ ,dz(nlma,nnp1),ddz(nlma,nnp1),dp(nlma,nnp1)
+ $ ,db(nlma,nnp1),ddb(nlma,nnp1),dj(nlma,nnp1)
+ common /com55/ dwdt(nlma,nn,2)
+ common /com56/ dzdt(nlma,nn,2)
+ common /com57/ dpdt(nlma,nn,2)
+ common /com58/ dsdt(nlma,nn,2)
+ common /com59/ b(nlma,nnp1),aj(nlma,nnp1)
+ common /com512/ dbdt(nlma,nn,2)
+ common /com513/ djdt(nlma,nn,2)
+c
+ complex w,z,s,p,dw,ddw,dddw,dz,ddz,dp,dwdt,dzdt,
+ $ dpdt,dsdt
+ complex b,aj,db,ddb,dj,dbdt,djdt
+c
+ complex dwdt1(nlma,nn),dzdt1(nlma,nn),
+ $dsdt1(nlma,nn),dpdt1(nlma,nn)
+ equivalence (dwdt,dwdt1),(dzdt,dzdt1),(dsdt,dsdt1),(dpdt,dpdt1)
+ complex dbdt1(nlma,nn),djdt1(nlma,nn)
+ equivalence (dbdt,dbdt1),(djdt,djdt1)
Added: 3D/MAG/trunk/src/com6.f
===================================================================
--- 3D/MAG/trunk/src/com6.f 2006-06-26 21:27:17 UTC (rev 3892)
+++ 3D/MAG/trunk/src/com6.f 2006-06-27 00:20:45 UTC (rev 3893)
@@ -0,0 +1,19 @@
+ common /com6/ vrc(ncp,ni),vtc(ncp,ni),vpc(ncp,ni),
+ $dvrdrc(ncp,ni),dvtdrc(ncp,ni),dvpdrc(ncp,ni),
+ $cvrc(ncp,ni),dvrdtc(ncp,ni),dvrdpc(ncp,ni),
+ $dvtdpc(ncp,ni),dvpdpc(ncp,ni),
+ $brc(ncp,ni),btc(ncp,ni),bpc(ncp,ni),
+ $cbrc(ncp,ni),cbtc(ncp,ni),cbpc(ncp,ni),
+ $bnlc1(ncp,ni),bnlc2(ncp,ni),bnlc3(ncp,ni),
+ $wnlc1(ncp,ni),wnlc2(ncp,ni),wnlc3(ncp,ni),
+ $sc(ncp,ni),snlc1(ncp,ni),snlc2(ncp,ni),snlc3(ncp,ni)
+c
+ complex vrc,vtc,vpc,
+ $dvrdrc,dvtdrc,dvpdrc,
+ $cvrc,dvrdtc,dvrdpc,
+ $dvtdpc,dvpdpc,
+ $brc,btc,bpc,
+ $cbrc,cbtc,cbpc,
+ $bnlc1,bnlc2,bnlc3,
+ $wnlc1,wnlc2,wnlc3,
+ $sc,snlc1,snlc2,snlc3
Added: 3D/MAG/trunk/src/com7.f
===================================================================
--- 3D/MAG/trunk/src/com7.f 2006-06-26 21:27:17 UTC (rev 3892)
+++ 3D/MAG/trunk/src/com7.f 2006-06-27 00:20:45 UTC (rev 3893)
@@ -0,0 +1,2 @@
+ common /com7/ cheb(nn,nn),dcheb(nn,nn),d2cheb(nn,nn),
+ $ d3cheb(nn,nn)
Added: 3D/MAG/trunk/src/com8.f
===================================================================
--- 3D/MAG/trunk/src/com8.f 2006-06-26 21:27:17 UTC (rev 3892)
+++ 3D/MAG/trunk/src/com8.f 2006-06-27 00:20:45 UTC (rev 3893)
@@ -0,0 +1,10 @@
+ common /com8/
+ $up(nja,3),urdp(nja),
+ $bts(ni,3),brdt(ni),
+ $ngform,ngrad,ngcolat,nglon,runid,
+ $tscale,vscale,pscale,escale,alum0,
+ $tmovstart,tmovstep,tmovnext,iframes,
+ $imovct,imovopt
+ common /stop/ istop
+c
+ character*64 runid
Added: 3D/MAG/trunk/src/copydat.f
===================================================================
--- 3D/MAG/trunk/src/copydat.f 2006-06-26 21:27:17 UTC (rev 3892)
+++ 3D/MAG/trunk/src/copydat.f 2006-06-27 00:20:45 UTC (rev 3893)
@@ -0,0 +1,67 @@
+ subroutine copydat(dat,dato,nlma,nlmao,lmax,lmaxo,mmax,mmaxo,
+ $ minc,minco,nr,nrold,nr1,nr32,r,rold)
+c
+c copy data into correct locations (old grid > new grid)
+c
+c called in mapdata
+c
+ logical ifold
+ complex dat(nlma,nr1),dato(nlmao,*)
+ dimension r(nr),rold(nr32)
+ dimension fcmin(129)
+ integer kcmin(129)
+c
+ nn=nr1-1
+ if(nrold.ne.nr) then
+ kcmin(1)=1
+ fcmin(1)=1.
+ kcmin(nn)=nrold+nn-nr-1
+ fcmin(nn)=0.
+ do kc=2,nn-1
+ kco=kcmin(kc-1)
+ 10 if(r(kc).gt.rold(kco+1)) then
+ kcmin(kc)=kco
+ fcmin(kc)=(rold(kco+1)-r(kc))/(rold(kco+1)-rold(kco))
+ else
+ kco=kco+1
+ if(kco.gt.nrold) stop '55'
+ go to 10
+ endif
+ enddo
+ endif
+c
+ do m=0,mmax,minc
+ mm=m*(m-minc)/(2*minc)
+ if(m.gt.mmaxo .or. mod(m,minco).ne.0) then
+ ifold=.false.
+ else
+ ifold=.true.
+ mmo=m*(m-minco)/(2*minco)
+ endif
+c
+ do l=m,lmax
+ lm=m*(lmax+1)/minc-mm+l-m+1
+ if( ifold .and. l.le.lmaxo ) then
+ lmo=m*(lmaxo+1)/minco-mmo+l-m+1
+ if(nr.eq.nrold) then
+ do kc=1,nn
+ dat(lm,kc)=dato(lmo,kc)
+ enddo
+ else
+ do kc=1,nn
+ kco=kcmin(kc)
+ dat(lm,kc)=fcmin(kc)*dato(lmo,kco)
+ $ +(1.-fcmin(kc))*dato(lmo,kco+1)
+ enddo
+ if(nr.gt.nn) dat(lm,nr)=dato(lmo,nrold)
+ endif
+ else
+ do kc=1,nr
+ dat(lm,kc)=(0.0,0.0)
+ enddo
+ endif
+ enddo
+ enddo
+c
+ return
+ end
Added: 3D/MAG/trunk/src/dtchck.f
===================================================================
--- 3D/MAG/trunk/src/dtchck.f 2006-06-26 21:27:17 UTC (rev 3892)
+++ 3D/MAG/trunk/src/dtchck.f 2006-06-27 00:20:45 UTC (rev 3893)
@@ -0,0 +1,44 @@
+ subroutine dtchck(kstep,newdt,dt,dtnew,
+ $dtmin,dtmax,dtr,dth,ifirst,kcour)
+c
+c *** Check if Courant criterion based on combined
+c *** fluid and Alfven velocity is satisfied
+c *** Returns new value of time step dtnew
+c
+ kcour=max(kcour-1,0)
+c
+ if(ifirst .eq. 1) then
+ ifirst=0
+ if(abs((dt-dtmax)/dt) .lt. 1.e-7) dt=dtmax
+ endif
+c
+ dtnew=dt
+c
+ dtlo=0.5
+ dtrh=min(dtr,dth)
+ dt2=min(0.5*(dtlo+1.0)*dtrh,dtmax)
+ if(dt .le. dtmax) go to 40
+ write(6,20) kstep,dtmax
+ go to 50
+c
+ 40 dtlim= dtrh
+ if(dt .le. dtlim) go to 10
+ write(6,20) kstep,dtr,dth
+ 20 format(/,1x,"step=",i6,2x,"dt> dtr or dth=",2e12.4)
+ go to 50
+c
+ 10 dtlim=dtlo*dtrh
+ if((dt .ge. dtlim) .or. (dt .ge. dtmax)) return
+ write(6,30) kstep,dtr,dth
+ 30 format(/,1x,"step=",i6,2x,"2*dt< dtr and dth=",2e12.4)
+c
+ 50 dtnew=dt2
+ if(dtnew .lt. dtmin) dtmin=0. ! Signal to stop
+ newdt=1
+ write(6,25) dtnew
+ 25 format(12x,"dt changed to ",e12.4)
+c
+ kcour=2
+c
+ return
+ end
Added: 3D/MAG/trunk/src/fact.f
===================================================================
--- 3D/MAG/trunk/src/fact.f 2006-06-26 21:27:17 UTC (rev 3892)
+++ 3D/MAG/trunk/src/fact.f 2006-06-27 00:20:45 UTC (rev 3893)
@@ -0,0 +1,54 @@
+ subroutine fact(n,ifax)
+c
+c factorization routine that first extracts all factors of 4
+c
+c called in chebi
+c
+ dimension ifax(*)
+ if (n.gt.1) go to 10
+ ifax(1) = 0
+ if (n.lt.1) ifax(1) = -99
+ return
+ 10 nn=n
+ k=1
+c test for factors of 4
+ 20 if (mod(nn,4).ne.0) go to 30
+ k=k+1
+ ifax(k)=4
+ nn=nn/4
+ if (nn.eq.1) go to 80
+ go to 20
+c test for extra factor of 2
+ 30 if (mod(nn,2).ne.0) go to 40
+ k=k+1
+ ifax(k)=2
+ nn=nn/2
+ if (nn.eq.1) go to 80
+c test for factors of 3
+ 40 if (mod(nn,3).ne.0) go to 50
+ k=k+1
+ ifax(k)=3
+ nn=nn/3
+ if (nn.eq.1) go to 80
+ go to 40
+c now find remaining factors
+ 50 l=5
+ max = sqrt(float(nn))
+ inc=2
+c inc alternately takes on values 2 and 4
+ 60 if (mod(nn,l).ne.0) go to 70
+ k=k+1
+ ifax(k)=l
+ nn=nn/l
+ if (nn.eq.1) go to 80
+ go to 60
+ 70 if (l.gt.max) go to 75
+ l=l+inc
+ inc=6-inc
+ go to 60
+ 75 k = k+1
+ ifax(k) = nn
+ 80 ifax(1)=k-1
+c ifax(1) now contains number of factors
+ return
+ end
Added: 3D/MAG/trunk/src/fax.f
===================================================================
--- 3D/MAG/trunk/src/fax.f 2006-06-26 21:27:17 UTC (rev 3892)
+++ 3D/MAG/trunk/src/fax.f 2006-06-27 00:20:45 UTC (rev 3893)
@@ -0,0 +1,63 @@
+ subroutine fax(ifax,n,mode)
+c
+c called in prep
+c
+ dimension ifax(*)
+ nn=n
+ if (iabs(mode).eq.1) go to 10
+ if (iabs(mode).eq.8) go to 10
+ nn=n/2
+ if ((nn+nn).eq.n) go to 10
+ ifax(1)=-99
+ return
+ 10 k=1
+c test for factors of 4
+ 20 if (mod(nn,4).ne.0) go to 30
+ k=k+1
+ ifax(k)=4
+ nn=nn/4
+ if (nn.eq.1) go to 80
+ go to 20
+c test for extra factor of 2
+ 30 if (mod(nn,2).ne.0) go to 40
+ k=k+1
+ ifax(k)=2
+ nn=nn/2
+ if (nn.eq.1) go to 80
+c test for factors of 3
+ 40 if (mod(nn,3).ne.0) go to 50
+ k=k+1
+ ifax(k)=3
+ nn=nn/3
+ if (nn.eq.1) go to 80
+ go to 40
+c now find remaining factors
+ 50 l=5
+ inc=2
+c inc alternately takes on values 2 and 4
+ 60 if (mod(nn,l).ne.0) go to 70
+ k=k+1
+ ifax(k)=l
+ nn=nn/l
+ if (nn.eq.1) go to 80
+ go to 60
+ 70 l=l+inc
+ inc=6-inc
+ go to 60
+ 80 ifax(1)=k-1
+c ifax(1) contains number of factors
+ nfax=ifax(1)
+c sort factors into ascending order
+ if (nfax.eq.1) go to 110
+ do 100 ii=2,nfax
+ istop=nfax+2-ii
+ do 90 i=2,istop
+ if (ifax(i+1).ge.ifax(i)) go to 90
+ item=ifax(i)
+ ifax(i)=ifax(i+1)
+ ifax(i+1)=item
+ 90 continue
+ 100 continue
+ 110 continue
+ return
+ end
Added: 3D/MAG/trunk/src/fft99a.f
===================================================================
--- 3D/MAG/trunk/src/fft99a.f 2006-06-26 21:27:17 UTC (rev 3892)
+++ 3D/MAG/trunk/src/fft99a.f 2006-06-27 00:20:45 UTC (rev 3893)
@@ -0,0 +1,77 @@
+ subroutine fft99a(a,work,trigs,inc,jump,n,lot)
+c
+ dimension a(*),work(*),trigs(*)
+c
+c preprocessing step (isign=+1)
+c (spectral to gridpoint transform)
+c
+c called in fourtf
+c
+ nh=n/2
+ nx=n+1
+ ink=inc+inc
+c
+c a(0) and a(n/2)
+ ia=1
+ ib=n*inc+1
+ ja=1
+ jb=2
+c dir$ ivdep
+ do 10 l=1,lot
+ work(ja)=a(ia)+a(ib)
+ work(jb)=a(ia)-a(ib)
+ ia=ia+jump
+ ib=ib+jump
+ ja=ja+nx
+ jb=jb+nx
+ 10 continue
+c
+c remaining wavenumbers
+ iabase=2*inc+1
+ ibbase=(n-2)*inc+1
+ jabase=3
+ jbbase=n-1
+c
+ do 30 k=3,nh,2
+ ia=iabase
+ ib=ibbase
+ ja=jabase
+ jb=jbbase
+ c=trigs(n+k)
+ s=trigs(n+k+1)
+c dir$ ivdep
+ do 20 l=1,lot
+ work(ja)=(a(ia)+a(ib))-
+ * (s*(a(ia)-a(ib))+c*(a(ia+inc)+a(ib+inc)))
+ work(jb)=(a(ia)+a(ib))+
+ * (s*(a(ia)-a(ib))+c*(a(ia+inc)+a(ib+inc)))
+ work(ja+1)=(c*(a(ia)-a(ib))-s*(a(ia+inc)+a(ib+inc)))+
+ * (a(ia+inc)-a(ib+inc))
+ work(jb+1)=(c*(a(ia)-a(ib))-s*(a(ia+inc)+a(ib+inc)))-
+ * (a(ia+inc)-a(ib+inc))
+ ia=ia+jump
+ ib=ib+jump
+ ja=ja+nx
+ jb=jb+nx
+ 20 continue
+ iabase=iabase+ink
+ ibbase=ibbase-ink
+ jabase=jabase+2
+ jbbase=jbbase-2
+ 30 continue
+c
+ if (iabase.ne.ibbase) go to 50
+c wavenumber n/4 (if it exists)
+ ia=iabase
+ ja=jabase
+c dir$ ivdep
+ do 40 l=1,lot
+ work(ja)=2.0*a(ia)
+ work(ja+1)=-2.0*a(ia+inc)
+ ia=ia+jump
+ ja=ja+nx
+ 40 continue
+c
+ 50 continue
+ return
+ end
Added: 3D/MAG/trunk/src/fft99b.f
===================================================================
--- 3D/MAG/trunk/src/fft99b.f 2006-06-26 21:27:17 UTC (rev 3892)
+++ 3D/MAG/trunk/src/fft99b.f 2006-06-27 00:20:45 UTC (rev 3893)
@@ -0,0 +1,82 @@
+ subroutine fft99b(work,a,trigs,inc,jump,n,lot)
+c
+ dimension work(*),a(*),trigs(*)
+c
+c postprocessing step (isign=-1)
+c (gridpoint to spectral transform)
+c
+c called in fourtf
+c
+ nh=n/2
+ nx=n+1
+ ink=inc+inc
+c
+c a(0) and a(n/2)
+ scale=1.0/float(n)
+ ia=1
+ ib=2
+ ja=1
+ jb=n*inc+1
+c dir$ ivdep
+ do 10 l=1,lot
+ a(ja)=scale*(work(ia)+work(ib))
+ a(jb)=scale*(work(ia)-work(ib))
+ a(ja+inc)=0.0
+ a(jb+inc)=0.0
+ ia=ia+nx
+ ib=ib+nx
+ ja=ja+jump
+ jb=jb+jump
+ 10 continue
+c
+c remaining wavenumbers
+ scale=0.5*scale
+ iabase=3
+ ibbase=n-1
+ jabase=2*inc+1
+ jbbase=(n-2)*inc+1
+c
+ do 30 k=3,nh,2
+ ia=iabase
+ ib=ibbase
+ ja=jabase
+ jb=jbbase
+ c=trigs(n+k)
+ s=trigs(n+k+1)
+c dir$ ivdep
+ do 20 l=1,lot
+ a(ja)=scale*((work(ia)+work(ib))
+ * +(c*(work(ia+1)+work(ib+1))+s*(work(ia)-work(ib))))
+ a(jb)=scale*((work(ia)+work(ib))
+ * -(c*(work(ia+1)+work(ib+1))+s*(work(ia)-work(ib))))
+ a(ja+inc)=scale*((c*(work(ia)-work(ib))-s*(work(ia+1)+work(ib+1)))
+ * +(work(ib+1)-work(ia+1)))
+ a(jb+inc)=scale*((c*(work(ia)-work(ib))-s*(work(ia+1)+work(ib+1)))
+ * -(work(ib+1)-work(ia+1)))
+ ia=ia+nx
+ ib=ib+nx
+ ja=ja+jump
+ jb=jb+jump
+ 20 continue
+ iabase=iabase+2
+ ibbase=ibbase-2
+ jabase=jabase+ink
+ jbbase=jbbase-ink
+ 30 continue
+c
+ if (iabase.ne.ibbase) go to 50
+c wavenumber n/4 (if it exists)
+ ia=iabase
+ ja=jabase
+ scale=2.0*scale
+c dir$ ivdep
+ do 40 l=1,lot
+ a(ja)=scale*work(ia)
+ a(ja+inc)=-scale*work(ia+1)
+ ia=ia+nx
+ ja=ja+jump
+ 40 continue
+c
+ 50 continue
+ return
+ end
Added: 3D/MAG/trunk/src/fftrig.f
===================================================================
--- 3D/MAG/trunk/src/fftrig.f 2006-06-26 21:27:17 UTC (rev 3892)
+++ 3D/MAG/trunk/src/fftrig.f 2006-06-27 00:20:45 UTC (rev 3893)
@@ -0,0 +1,44 @@
+ subroutine fftrig(trigs,n,mode)
+c
+c called in prep
+c
+ dimension trigs(*)
+ pi=2.0*asin(1.0)
+ imode=iabs(mode)
+ nn=n
+ if (imode.gt.1.and.imode.lt.6) nn=n/2
+ del=(pi+pi)/float(nn)
+ l=nn+nn
+ do 10 i=1,l,2
+ angle=0.5*float(i-1)*del
+ trigs(i)=cos(angle)
+ trigs(i+1)=sin(angle)
+ 10 continue
+ if (imode.eq.1) return
+ if (imode.eq.8) return
+ del=0.5*del
+ nh=(nn+1)/2
+ l=nh+nh
+ la=nn+nn
+ do 20 i=1,l,2
+ angle=0.5*float(i-1)*del
+ trigs(la+i)=cos(angle)
+ trigs(la+i+1)=sin(angle)
+ 20 continue
+ if (imode.le.3) return
+ del=0.5*del
+ la=la+nn
+ if (mode.eq.5) go to 40
+ do 30 i=2,nn
+ angle=float(i-1)*del
+ trigs(la+i)=2.0*sin(angle)
+ 30 continue
+ return
+ 40 continue
+ del=0.5*del
+ do 50 i=2,n
+ angle=float(i-1)*del
+ trigs(la+i)=sin(angle)
+ 50 continue
+ return
+ end
Added: 3D/MAG/trunk/src/filter.f
===================================================================
--- 3D/MAG/trunk/src/filter.f 2006-06-26 21:27:17 UTC (rev 3892)
+++ 3D/MAG/trunk/src/filter.f 2006-06-27 00:20:45 UTC (rev 3893)
@@ -0,0 +1,43 @@
+ subroutine filter(ain,aout,kc,alfilt,nfilt,dipfilt)
+c
+c -filter depending on harmonic degree l acting on radial
+c -level kc of field ain(lm,kc)
+c -super-Gaussian filter F = exp (-[l/alfilt]^nfilt)
+c -or cos-taper F = 0.5(1-sin(pi*[l-nfilt]/|alfilt|)
+c -if lfilt<0
+c -result written into aout(lm)
+c
+c---------------------------------------------------------------
+ include 'param.f'
+ include 'com4.f'
+c
+ dimension filt(lmax)
+ complex
+ $ ain(nlma,nnp1),aout(nlma)
+c
+ if (alfilt.gt.0.0) then
+ do 200 l=1,lmax
+ filt(l)=exp(-((real(l)/alfilt)**nfilt))
+ 200 continue
+ else
+ do 201 l=1,lmax
+ arg=(l-nfilt)/alfilt
+ if(arg.gt.0.5) then
+ filt(l)=1.0
+ else if(arg.lt.-0.5) then
+ filt(l)=0.0
+ else
+ filt(l)=0.5*(1.+sin(pi*arg))
+ endif
+ 201 continue
+ endif
+c
+ do 203 lm=nlma,2,-1
+ l=nint(ql(lm,4))
+ aout(lm)=ain(lm,kc)*filt(l)
+ 203 continue
+ aout(1)=0.
+ aout(2)=dipfilt*aout(2)
+c
+ return
+ end
Added: 3D/MAG/trunk/src/fourtf.f
===================================================================
--- 3D/MAG/trunk/src/fourtf.f 2006-06-26 21:27:17 UTC (rev 3892)
+++ 3D/MAG/trunk/src/fourtf.f 2006-06-27 00:20:45 UTC (rev 3893)
@@ -0,0 +1,191 @@
+ subroutine fourtf(a,work,trigs,ifax,inc,jump,n,lot,isign)
+c
+c same as fft991
+c
+c called in amhd
+c
+c
+c purpose perform a number of simultaneous real/half-complex
+c periodic fast fourier transforms or corresponding inverse
+c transforms, using ordinary spatial order of
+c gridpoint values. given a set
+c of real data vectors, the package returns a set of
+c "half-complex" fourier coefficient vectors, or vice
+c versa. the length of the transforms must be an even
+c number that has no other factors except possibly powers
+c of 2, 3, and 5. this version of fft991 is
+c optimized for use on the cray-1.
+c
+c argument a(lot*(n+2)), work(lot*(n+1)), trigs(3*n/2+1), ifax(13)
+c dimensions
+c
+c arguments
+c
+c on input a
+c an array of length lot*(n+2) containing the input data
+c or coefficient vectors. this array is overwritten by
+c the results.
+c
+c work
+c a work array of dimension lot*(n+1)
+c
+c trigs
+c an array set up by fftfax, which must be called first.
+c
+c ifax
+c an array set up by fftfax, which must be called first.
+c
+c inc
+c the increment (in words) between successive elements of
+c each data or coefficient vector (e.g. inc=1 for
+c consecutively stored data).
+c
+c jump
+c the increment (in words) between the first elements of
+c successive data or coefficient vectors. on the cray-1,
+c try to arrange data so that jump is not a multiple of 8
+c (to avoid memory bank conflicts).
+c
+c n
+c the length of each transform (see definition of
+c transforms, below).
+c
+c lot
+c the number of transforms to be done simultaneously.
+c
+c isign
+c = +1 for a transform from fourier coefficients to
+c gridpoint values.
+c = -1 for a transform from gridpoint values to fourier
+c coefficients.
+c
+c on output a
+c if isign = +1, and lot coefficient vectors are supplied
+c each containing the sequence
+c
+c a(0),b(0),a(1),b(1),...,a(n/2),b(n/2) (n+2 values)
+c
+c then the result consists of lot data vectors each
+c containing the corresponding n+2 gridpoint values
+c
+c for fft991, x(0), x(1), x(2),...,x(n-1),0,0.
+c (n+2) real values with x(n)=x(n+1)=0
+c
+c when isign = +1, the transform is defined by
+c x(j)=sum(k=0,...,n-1)(c(k)*exp(2*i*j*k*pi/n))
+c where c(k)=a(k)+i*b(k) and c(n-k)=a(k)-i*b(k)
+c and i=sqrt (-1)
+c for k=0,...,n/2 i.e., (n/2+1) complex values
+c with c(0) = c(n) = a(0) and c(n/2)=a(n/2)=0
+c
+c if isign = -1, and lot data vectors are supplied each
+c containing a sequence of gridpoint values x(j) as
+c defined above, then the result consists of lot vectors
+c each containing the corresponding fourier cofficients
+c a(k), b(k), 0 .le. k .le n/2.
+c
+c when isign = -1, the inverse transform is defined by
+c c(k)=(1/n)*sum(j=0,...,n-1)(x(j)*exp(-2*i*j*k*pi/n))
+c where c(k)=a(k)+i*b(k) and i=sqrt(-1)
+c for k=0,...,n/2
+c
+c a call with isign=+1 followed by a call with isign=-1
+c (or vice versa) returns the original data.
+c
+c note the fact that the gridpoint values x(j) are real
+c implies that b(0)=b(n/2)=0. for a call with isign=+1,
+c it is not actually necessary to supply these zeros.
+c note starting from grid with x(n)=x(n+1)=0
+c then transforming to spectral (sign=-1)
+c then c(n/2)=a(n/2) is not necessarily 0
+c unless there is no aliasing.
+c
+ dimension a(*),work(*),trigs(*),ifax(*)
+c
+ nfax=ifax(1)
+ nx=n+1
+ nh=n/2
+ ink=inc+inc
+ if (isign.eq.+1) go to 10
+c
+ igo=50
+ if (mod(nfax,2).eq.1) goto 40
+ ibase=1
+ jbase=1
+ do 21 l=1,lot
+ i=ibase
+ j=jbase
+ do 11 m=1,n
+ work(j)=a(i)
+ i=i+inc
+ j=j+1
+ 11 continue
+ ibase=ibase+jump
+ jbase=jbase+nx
+ 21 continue
+ igo=60
+ go to 40
+c
+c preprocessing (isign=+1)
+c
+ 10 continue
+ call fft99a(a,work,trigs,inc,jump,n,lot)
+ igo=60
+c
+c complex transform
+c
+ 40 continue
+ ia=1
+ la=1
+ do 80 k=1,nfax
+ if (igo.eq.60) go to 60
+ 50 continue
+ call wpassm(a(ia),a(ia+inc),work(1),work(2),trigs,
+ * ink,2,jump,nx,lot,nh,ifax(k+1),la)
+ igo=60
+ go to 70
+ 60 continue
+ call wpassm(work(1),work(2),a(ia),a(ia+inc),trigs,
+ * 2,ink,nx,jump,lot,nh,ifax(k+1),la)
+ igo=50
+ 70 continue
+ la=la*ifax(k+1)
+ 80 continue
+c
+ if (isign.eq.-1) go to 130
+c
+ if (mod(nfax,2).eq.1) go to 110
+ ibase=1
+ jbase=1
+ do 100 l=1,lot
+ i=ibase
+ j=jbase
+ do 90 m=1,n
+ a(j)=work(i)
+ i=i+1
+ j=j+inc
+ 90 continue
+ ibase=ibase+nx
+ jbase=jbase+jump
+ 100 continue
+c
+c fill in zeros
+c
+ 110 continue
+ ib=n*inc+1
+cdir$ ivdep
+ do 120 l=1,lot
+ a(ib)=0.0
+ a(ib+inc)=0.0
+ ib=ib+jump
+ 120 continue
+ go to 140
+c
+c postprocessing (isign=-1)
+c
+ 130 continue
+ call fft99b(work,a,trigs,inc,jump,n,lot)
+c
+ 140 continue
+ return
+ end
Added: 3D/MAG/trunk/src/gquad.f
===================================================================
--- 3D/MAG/trunk/src/gquad.f 2006-06-26 21:27:17 UTC (rev 3892)
+++ 3D/MAG/trunk/src/gquad.f 2006-06-27 00:20:45 UTC (rev 3893)
@@ -0,0 +1,63 @@
+ subroutine gquad(l,root,w)
+c
+c gquad (linked with pbar) finds the l roots (in theta)
+c and gaussian weights associated with
+c the legendre polynomial of degree l > 1
+c
+c called in prep
+c
+ dimension root(l),w(l)
+c
+ pi=4.*atan(1.)
+ del=pi/float(4*l)
+ l1=l+1
+ co=float(2*l+3)/float(l1**2)
+ p2=1.
+ t2=-del
+ l2=l/2
+ k=1
+c
+ do 10 i=1,l2
+ 20 t1=t2
+ t2=t1+del
+ theta=t2
+ call pbar(theta,l,0,p)
+ p1=p2
+ p2=p
+ if((k*p2) .gt. 0.) go to 20
+ k=-k
+ 40 s=(t2-t1)/(p2-p1)
+ t1=t2
+ t2=t2-s*p2
+ theta=t2
+ call pbar(theta,l,0,p)
+ p1=p2
+ p2=p
+ if(abs(p) .le. 1.e-10) go to 30
+ if(p2 .eq. p1) then
+c write(6,*) 'sub gquad: zero = ',p,' at i = ',i
+ go to 30
+ endif
+ go to 40
+ 30 root(i)=theta
+ call pbar(theta,l1,0,p)
+ w(i)=co*(sin(theta)/p)**2
+ 10 continue
+c
+ l22=2*l2
+ if(l22 .eq. l) go to 70
+ l2=l2+1
+ theta=pi/2.
+ root(l2)=theta
+ call pbar(theta,l1,0,p)
+ w(l2)=co/p**2
+ 70 continue
+c
+ l3=l2+1
+ do 50 i=l3,l
+ root(i)=pi-root(l-i+1)
+ w(i)=w(l-i+1)
+ 50 continue
+c
+ return
+ end
Added: 3D/MAG/trunk/src/graphout.f
===================================================================
--- 3D/MAG/trunk/src/graphout.f 2006-06-26 21:27:17 UTC (rev 3892)
+++ 3D/MAG/trunk/src/graphout.f 2006-06-27 00:20:45 UTC (rev 3893)
@@ -0,0 +1,252 @@
+ subroutine graphout(kc,iwrit)
+c
+c supplied by urc
+c
+c called in amhd
+c
+c output of components of velocity, magnetic field vector and
+c entropy for graphics
+c for kc=0 a header is written
+c for kc>0 values at radial level kc are written
+c
+ include 'param.f'
+ include 'com1.f'
+ include 'com3.f'
+ include 'com4.f'
+ include 'com5.f'
+ include 'com6.f'
+ include 'com8.f'
+c
+ dimension vr(nrp,ni),vt(nrp,ni),vp(nrp,ni)
+ dimension br(nrp,ni),bt(nrp,ni),bp(nrp,ni)
+ dimension cbr(nrp,ni),cbt(nrp,ni),cbp(nrp,ni)
+ dimension sr(nrp,ni)
+ dimension brf(nrp,ni)
+ complex brfc(ncp,ni)
+ complex blm(nlma)
+c
+ real*4 dumm0,dumm1(ni),dummy(nj,ni)
+c
+ equivalence (vr,vrc),(vt,vtc),(vp,vpc)
+ equivalence (br,brc),(bt,btc),(bp,bpc)
+ equivalence (cbr,cbrc),(cbt,cbtc),(cbp,cbpc)
+ equivalence (sr,sc)
+ equivalence (brf,brfc)
+c
+ save smin
+c
+ if(iwrit.eq.0) return
+c
+ nim=ni
+ nis=ngcolat
+ njm=nja
+ njs=nglon
+ if(kc.eq.1) smin=sr(1,1)
+c
+ if(kc.gt.0) go to 300
+c
+c write header & colatitudes
+c
+ if(iwrit.lt.2) then
+ write(14,'(A64)') runid
+ if(iwrit.lt.0)
+ $ write(14,'(/'' Time,nn,ni,nj,ngrad,nglon,minc:'')')
+ write(14,'(e12.5,1x,7i6)') time,nn,ni,nj,ngrad,ngcolat,
+ $ nglon,minc
+ write(14,'(5e14.6)') ra,ek,pr,prmag,radratio
+
+ if(iwrit.lt.0) write(14,'(/'' Colatitudes '')')
+ write(14,'(129(1x,f8.5))') (qi(ic,5),ic=1,nim,nis)
+ else
+ write(14) runid
+ dumm0=time
+ write(14) dumm0,nn,ni,nj,ngrad,ngcolat,nglon,minc
+ dumm1(1)=ra
+ dumm1(2)=ek
+ dumm1(3)=pr
+ dumm1(4)=prmag
+ dumm1(5)=radratio
+ write(14) (dumm1(i),i=1,5)
+ do ic=1,nim,nis
+ dumm1(ic)=qi(ic,5)
+ enddo
+ write(14) (dumm1(ic),ic=1,nim,nis)
+ endif
+c
+ return
+c
+c output for radial levels
+c
+ 300 if(iwrit.lt.0) write(14,'(/'' Radial level, radius '')')
+ if(iwrit.lt.2) then
+ write(14,'(i4,1x,f9.5)') kc,r(kc)/radtop
+ else
+ dumm0=r(kc)/radtop
+ write(14) kc,dumm0
+ endif
+c
+c write entropy
+c
+ if(iwrit.lt.0) write(14,'(/'' S: '')')
+ if(iwrit.lt.2) then
+ do ic=1,nim,nis
+ write(14,902) ((sr(jc,ic)-smin),jc=1,njm,njs)
+ enddo
+ else
+ do ic=1,nim,nis
+ do jc=1,njm,njs
+ dummy(jc,ic)=sr(jc,ic)-smin
+ enddo
+ enddo
+ write(14) ((dummy(jc,ic),jc=1,njm,njs),ic=1,nim,nis)
+ endif
+ 350 continue
+c
+c calculate and write radial velocity
+c
+ if(iwrit.lt.0) write(14,'(/'' Vr: '')')
+ if(kc.eq.1.and.nfilt.gt.0.and.ivfilt.gt.0) then
+ call filter(w,blm,ivfilt,alfilt,nfilt,1.0)
+ call spherictf(blm,brfc)
+ do ic=1,nim,nis
+ do jc=1,njm,njs
+ dummy(jc,ic)=brf(jc,ic)*qk(ivfilt,1)/vscale
+ enddo
+ enddo
+ else
+ do ic=1,nim,nis
+ do jc=1,njm,njs
+ dummy(jc,ic)=vr(jc,ic)*qk(kc,1)/vscale
+ enddo
+ enddo
+ endif
+ if(iwrit.lt.2) then
+ do ic=1,nim,nis
+ write(14,900) (dummy(jc,ic),jc=1,njm,njs)
+ enddo
+ else
+ write(14) ((dummy(jc,ic),jc=1,njm,njs),ic=1,nim,nis)
+ endif
+c
+c calculate and write latitudinal velocity
+c
+ if(iwrit.lt.0) write(14,'(/'' Vt: '')')
+ do ic=1,nim,nis
+ do jc=1,njm,njs
+ dummy(jc,ic)=vt(jc,ic)*qk(kc,3)/(vscale*qi(ic,3))
+ enddo
+ enddo
+ if(iwrit.lt.2) then
+ do ic=1,nim,nis
+ write(14,900) (dummy(jc,ic),jc=1,njm,njs)
+ enddo
+ else
+ write(14) ((dummy(jc,ic),jc=1,njm,njs),ic=1,nim,nis)
+ endif
+c
+c calculate and write longitudinal velocity
+c
+ if(iwrit.lt.0) write(14,'(/'' Vp: '')')
+ do ic=1,nim,nis
+ do jc=1,njm,njs
+ dummy(jc,ic)=vp(jc,ic)*qk(kc,3)/(vscale*qi(ic,3))
+ enddo
+ enddo
+ if(iwrit.lt.2) then
+ do ic=1,nim,nis
+ write(14,900) (dummy(jc,ic),jc=1,njm,njs)
+ enddo
+ else
+ write(14) ((dummy(jc,ic),jc=1,njm,njs),ic=1,nim,nis)
+ endif
+c
+c calculate and write radial magnetic field
+c
+ if(iwrit.lt.0) write(14,'(/'' Br: '')')
+ if(kc.eq.1.and.nfilt.gt.0) then
+ call filter(b,blm,1,alfilt,nfilt,dipfilt)
+ call spherictf(blm,brfc)
+ do ic=1,nim,nis
+ do jc=1,njm,njs
+ dummy(jc,ic)=brf(jc,ic)*qk(1,1)
+ enddo
+ enddo
+ else
+ do ic=1,nim,nis
+ do jc=1,njm,njs
+ dummy(jc,ic)=br(jc,ic)*qk(kc,1)
+ enddo
+ enddo
+ endif
+ if(iwrit.lt.2) then
+ do ic=1,nim,nis
+ write(14,901) (dummy(jc,ic),jc=1,njm,njs)
+ enddo
+ else
+ write(14) ((dummy(jc,ic),jc=1,njm,njs),ic=1,nim,nis)
+ endif
+c
+c calculate and write latitudinal magnetic field
+c
+ if(iwrit.lt.0) write(14,'(/'' Bt: '')')
+ do ic=1,nim,nis
+ do jc=1,njm,njs
+ dummy(jc,ic)=bt(jc,ic)*qk(kc,3)/qi(ic,3)
+ enddo
+ enddo
+ if(iwrit.lt.2) then
+ do ic=1,nim,nis
+ write(14,901) (dummy(jc,ic),jc=1,njm,njs)
+ enddo
+ else
+ write(14) ((dummy(jc,ic),jc=1,njm,njs),ic=1,nim,nis)
+ endif
+c
+c calculate and write longitudinal magnetic field
+c
+ if(iwrit.lt.0) write(14,'(/'' Bp: '')')
+ do ic=1,nim,nis
+ do jc=1,njm,njs
+ dummy(jc,ic)=bp(jc,ic)*qk(kc,3)/qi(ic,3)
+ enddo
+ enddo
+ if(iwrit.lt.2) then
+ do ic=1,nim,nis
+ write(14,901) (dummy(jc,ic),jc=1,njm,njs)
+ enddo
+ else
+ write(14) ((dummy(jc,ic),jc=1,njm,njs),ic=1,nim,nis)
+ endif
+c
+c if iwrit > 2 write also components of curl(B)
+c
+ if(iwrit.le.2) return
+c
+c r-component
+ do ic=1,nim,nis
+ do jc=1,njm,njs
+ dummy(jc,ic)=cbr(jc,ic)*qk(kc,1)
+ enddo
+ enddo
+ write(14) ((dummy(jc,ic),jc=1,njm,njs),ic=1,nim,nis)
+c theta-component
+ do ic=1,nim,nis
+ do jc=1,njm,njs
+ dummy(jc,ic)=cbt(jc,ic)*qk(kc,3)/qi(ic,3)
+ enddo
+ enddo
+ write(14) ((dummy(jc,ic),jc=1,njm,njs),ic=1,nim,nis)
+c phi-component
+ do ic=1,nim,nis
+ do jc=1,njm,njs
+ dummy(jc,ic)=cbp(jc,ic)*qk(kc,3)/qi(ic,3)
+ enddo
+ enddo
+ write(14) ((dummy(jc,ic),jc=1,njm,njs),ic=1,nim,nis)
+
+ 900 format(256(1X,f7.2))
+ 901 format(256(1X,f7.3))
+ 902 format(256(1X,f7.5))
+c
+ return
+ end
Added: 3D/MAG/trunk/src/graphout_org.f
===================================================================
--- 3D/MAG/trunk/src/graphout_org.f 2006-06-26 21:27:17 UTC (rev 3892)
+++ 3D/MAG/trunk/src/graphout_org.f 2006-06-27 00:20:45 UTC (rev 3893)
@@ -0,0 +1,252 @@
+ subroutine graphout(kc,iwrit)
+c
+c supplied by urc
+c
+c called in amhd
+c
+c output of components of velocity, magnetic field vector and
+c entropy for graphics
+c for kc=0 a header is written
+c for kc>0 values at radial level kc are written
+c
+ include 'param.f'
+ include 'com1.f'
+ include 'com3.f'
+ include 'com4.f'
+ include 'com5.f'
+ include 'com6.f'
+ include 'com8.f'
+c
+ dimension vr(nrp,ni),vt(nrp,ni),vp(nrp,ni)
+ dimension br(nrp,ni),bt(nrp,ni),bp(nrp,ni)
+ dimension cbr(nrp,ni),cbt(nrp,ni),cbp(nrp,ni)
+ dimension sr(nrp,ni)
+ dimension brf(nrp,ni)
+ complex brfc(ncp,ni)
+ complex blm(nlma)
+c
+ real*4 dumm0,dumm1(ni),dummy(nj,ni)
+c
+ equivalence (vr,vrc),(vt,vtc),(vp,vpc)
+ equivalence (br,brc),(bt,btc),(bp,bpc)
+ equivalence (cbr,cbrc),(cbt,cbtc),(cbp,cbpc)
+ equivalence (sr,sc)
+ equivalence (brf,brfc)
+c
+ save smin
+c
+ if(iwrit.eq.0) return
+c
+ nim=ni
+ nis=ngcolat
+ njm=nja
+ njs=nglon
+ if(kc.eq.1) smin=sr(1,1)
+c
+ if(kc.gt.0) go to 300
+c
+c write header & colatitudes
+c
+ if(iwrit.lt.2) then
+ write(14,'(A64)') runid
+ if(iwrit.lt.0)
+ $ write(14,'(/'' Time,nn,ni,nj,ngrad,nglon,minc:'')')
+ write(14,'(e12.5,1x,7i6)') time,nn,ni,nj,ngrad,ngcolat,
+ $ nglon,minc
+ write(14,'(5e14.6)') ra,ek,pr,prmag,radratio
+
+ if(iwrit.lt.0) write(14,'(/'' Colatitudes '')')
+ write(14,'(129(1x,f8.5))') (qi(ic,5),ic=1,nim,nis)
+ else
+ write(14) runid
+ dumm0=time
+ write(14) dumm0,nn,ni,nj,ngrad,ngcolat,nglon,minc
+ dumm1(1)=ra
+ dumm1(2)=ek
+ dumm1(3)=pr
+ dumm1(4)=prmag
+ dumm1(5)=radratio
+ write(14) (dumm1(i),i=1,5)
+ do ic=1,nim,nis
+ dumm1(ic)=qi(ic,5)
+ enddo
+ write(14) (dumm1(ic),ic=1,nim,nis)
+ endif
+c
+ return
+c
+c output for radial levels
+c
+ 300 if(iwrit.lt.0) write(14,'(/'' Radial level, radius '')')
+ if(iwrit.lt.2) then
+ write(14,'(i4,1x,f9.5)') kc,r(kc)/radtop
+ else
+ dumm0=r(kc)/radtop
+ write(14) kc,dumm0
+ endif
+c
+c write entropy
+c
+ if(iwrit.lt.0) write(14,'(/'' S: '')')
+ if(iwrit.lt.2) then
+ do ic=1,nim,nis
+ write(14,902) ((sr(jc,ic)-smin),jc=1,njm,njs)
+ enddo
+ else
+ do ic=1,nim,nis
+ do jc=1,njm,njs
+ dummy(jc,ic)=sr(jc,ic)-smin
+ enddo
+ enddo
+ write(14) ((dummy(jc,ic),jc=1,njm,njs),ic=1,nim,nis)
+ endif
+ 350 continue
+c
+c calculate and write radial velocity
+c
+ if(iwrit.lt.0) write(14,'(/'' Vr: '')')
+ if(kc.eq.1.and.nfilt.gt.0.and.ivfilt.gt.0) then
+ call filter(w,blm,ivfilt,alfilt,nfilt,1.0)
+ call spherictf(blm,brfc)
+ do ic=1,nim,nis
+ do jc=1,njm,njs
+ dummy(jc,ic)=brf(jc,ic)*qk(ivfilt,1)/vscale
+ enddo
+ enddo
+ else
+ do ic=1,nim,nis
+ do jc=1,njm,njs
+ dummy(jc,ic)=vr(jc,ic)*qk(kc,1)/vscale
+ enddo
+ enddo
+ endif
+ if(iwrit.lt.2) then
+ do ic=1,nim,nis
+ write(14,900) (dummy(jc,ic),jc=1,njm,njs)
+ enddo
+ else
+ write(14) ((dummy(jc,ic),jc=1,njm,njs),ic=1,nim,nis)
+ endif
+c
+c calculate and write latitudinal velocity
+c
+ if(iwrit.lt.0) write(14,'(/'' Vt: '')')
+ do ic=1,nim,nis
+ do jc=1,njm,njs
+ dummy(jc,ic)=vt(jc,ic)*qk(kc,3)/(vscale*qi(ic,3))
+ enddo
+ enddo
+ if(iwrit.lt.2) then
+ do ic=1,nim,nis
+ write(14,900) (dummy(jc,ic),jc=1,njm,njs)
+ enddo
+ else
+ write(14) ((dummy(jc,ic),jc=1,njm,njs),ic=1,nim,nis)
+ endif
+c
+c calculate and write longitudinal velocity
+c
+ if(iwrit.lt.0) write(14,'(/'' Vp: '')')
+ do ic=1,nim,nis
+ do jc=1,njm,njs
+ dummy(jc,ic)=vp(jc,ic)*qk(kc,3)/(vscale*qi(ic,3))
+ enddo
+ enddo
+ if(iwrit.lt.2) then
+ do ic=1,nim,nis
+ write(14,900) (dummy(jc,ic),jc=1,njm,njs)
+ enddo
+ else
+ write(14) ((dummy(jc,ic),jc=1,njm,njs),ic=1,nim,nis)
+ endif
+c
+c calculate and write radial magnetic field
+c
+ if(iwrit.lt.0) write(14,'(/'' Br: '')')
+ if(kc.eq.1.and.nfilt.gt.0) then
+ call filter(b,blm,1,alfilt,nfilt,dipfilt)
+ call spherictf(blm,brfc)
+ do ic=1,nim,nis
+ do jc=1,njm,njs
+ dummy(jc,ic)=brf(jc,ic)*qk(1,1)
+ enddo
+ enddo
+ else
+ do ic=1,nim,nis
+ do jc=1,njm,njs
+ dummy(jc,ic)=br(jc,ic)*qk(kc,1)
+ enddo
+ enddo
+ endif
+ if(iwrit.lt.2) then
+ do ic=1,nim,nis
+ write(14,901) (dummy(jc,ic),jc=1,njm,njs)
+ enddo
+ else
+ write(14) ((dummy(jc,ic),jc=1,njm,njs),ic=1,nim,nis)
+ endif
+c
+c calculate and write latitudinal magnetic field
+c
+ if(iwrit.lt.0) write(14,'(/'' Bt: '')')
+ do ic=1,nim,nis
+ do jc=1,njm,njs
+ dummy(jc,ic)=bt(jc,ic)*qk(kc,3)/qi(ic,3)
+ enddo
+ enddo
+ if(iwrit.lt.2) then
+ do ic=1,nim,nis
+ write(14,901) (dummy(jc,ic),jc=1,njm,njs)
+ enddo
+ else
+ write(14) ((dummy(jc,ic),jc=1,njm,njs),ic=1,nim,nis)
+ endif
+c
+c calculate and write longitudinal magnetic field
+c
+ if(iwrit.lt.0) write(14,'(/'' Bp: '')')
+ do ic=1,nim,nis
+ do jc=1,njm,njs
+ dummy(jc,ic)=bp(jc,ic)*qk(kc,3)/qi(ic,3)
+ enddo
+ enddo
+ if(iwrit.lt.2) then
+ do ic=1,nim,nis
+ write(14,901) (dummy(jc,ic),jc=1,njm,njs)
+ enddo
+ else
+ write(14) ((dummy(jc,ic),jc=1,njm,njs),ic=1,nim,nis)
+ endif
+c
+c if iwrit > 2 write also components of curl(B)
+c
+ if(iwrit.le.2) return
+c
+c r-component
+ do ic=1,nim,nis
+ do jc=1,njm,njs
+ dummy(jc,ic)=cbr(jc,ic)*qk(kc,1)
+ enddo
+ enddo
+ write(14) ((dummy(jc,ic),jc=1,njm,njs),ic=1,nim,nis)
+c theta-component
+ do ic=1,nim,nis
+ do jc=1,njm,njs
+ dummy(jc,ic)=cbt(jc,ic)*qk(kc,3)/qi(ic,3)
+ enddo
+ enddo
+ write(14) ((dummy(jc,ic),jc=1,njm,njs),ic=1,nim,nis)
+c phi-component
+ do ic=1,nim,nis
+ do jc=1,njm,njs
+ dummy(jc,ic)=cbp(jc,ic)*qk(kc,3)/qi(ic,3)
+ enddo
+ enddo
+ write(14) ((dummy(jc,ic),jc=1,njm,njs),ic=1,nim,nis)
+
+ 900 format(256(1X,f7.2))
+ 901 format(256(1X,f7.3))
+ 902 format(256(1X,f7.5))
+c
+ return
+ end
Added: 3D/MAG/trunk/src/kei.f
===================================================================
--- 3D/MAG/trunk/src/kei.f 2006-06-26 21:27:17 UTC (rev 3892)
+++ 3D/MAG/trunk/src/kei.f 2006-06-27 00:20:45 UTC (rev 3893)
@@ -0,0 +1,74 @@
+ subroutine kei(envp,envt,adrke,amcke)
+c
+c calculates total kinetic energy = 1/2 Integral (v^2 dV)
+c
+c---------------------------------------------------------------
+ include 'param.f'
+ include 'com1.f'
+ include 'com4.f'
+ include 'com5.f'
+c
+ complex c
+ cabssq(c)=real(c)**2+aimag(c)**2
+c---------------------------------------------------------------
+c
+ do 20 kc=1,nn
+ rvap(kc)=0.
+ rvat(kc)=0.
+ rvb(kc)=0.
+ rvc(kc)=0.
+ 20 continue
+c
+ do 30 lm=nlma,2,-1
+ do 31 kc=1,nn
+ rvap(kc)=rvap(kc)+
+ $ ql(lm,6)*(ql(lm,3)*qk(kc,1)*cabssq(w(lm,kc))
+ $ +4.*cabssq(dw(lm,kc)))
+ rvat(kc)=rvat(kc)+ql(lm,6)*cabssq(z(lm,kc))
+ 31 continue
+ 30 continue
+c
+ do 35 lm=nlaf,2,-1
+ do 36 kc=1,nn
+ rvb(kc)=rvb(kc)+ql(lm,6)*cabssq(z(lm,kc))
+ rvc(kc)=rvc(kc)+
+ $ ql(lm,6)*(ql(lm,3)*qk(kc,1)*cabssq(w(lm,kc))+
+ $ 4.*cabssq(dw(lm,kc)))
+ 36 continue
+ 35 continue
+c
+ call chebtf(1,ns2,1,nn1,ns2,rvap,rvap,rvap,wsave,
+ $work,work(2,1),work(2,1),work(2,1),trigsc,ifaxc,k2k)
+ call chebtf(1,ns2,1,nn1,ns2,rvat,rvat,rvat,wsave,
+ $work,work(2,1),work(2,1),work(2,1),trigsc,ifaxc,k2k)
+ call chebtf(1,ns2,1,nn1,ns2,rvb,rvb,rvb,wsave,
+ $work,work(2,1),work(2,1),work(2,1),trigsc,ifaxc,k2k)
+ call chebtf(1,ns2,1,nn1,ns2,rvc,rvc,rvc,wsave,
+ $work,work(2,1),work(2,1),work(2,1),trigsc,ifaxc,k2k)
+c
+ envp=0.
+ envt=0.
+ adrke=0.
+ amcke=0.
+ rvap(1)=0.5*rvap(1)
+ rvap(nn)=0.5*rvap(nn)
+ rvat(1)=0.5*rvat(1)
+ rvat(nn)=0.5*rvat(nn)
+ rvb(1)=0.5*rvb(1)
+ rvb(nn)=0.5*rvb(nn)
+ rvc(1)=0.5*rvc(1)
+ rvc(nn)=0.5*rvc(nn)
+ do 50 ncb=1,nn,2
+ nc=nnp1-ncb
+ envp=envp+rvap(nc)*qn(nc,3)
+ envt=envt+rvat(nc)*qn(nc,3)
+ adrke=adrke+rvb(nc)*qn(nc,3)
+ amcke=amcke+rvc(nc)*qn(nc,3)
+ 50 continue
+ envp=0.5*anorm*envp
+ envt=0.5*anorm*envt
+ adrke=0.5*anorm*adrke
+ amcke=0.5*anorm*amcke
+c
+ return
+ end
Added: 3D/MAG/trunk/src/legtf.f
===================================================================
--- 3D/MAG/trunk/src/legtf.f 2006-06-26 21:27:17 UTC (rev 3892)
+++ 3D/MAG/trunk/src/legtf.f 2006-06-27 00:20:45 UTC (rev 3893)
@@ -0,0 +1,120 @@
+ subroutine legtf(kc)
+c
+c -legendre transform from (k,l,m) to (k,i,m)
+c
+c---------------------------------------------------------------
+ include 'param.f'
+ include 'com4.f'
+ include 'com5.f'
+ include 'com6.f'
+c
+ complex
+ $cs1(nlma),cs2(nlma),cs3(nlma),cs4(nlma),cs5(nlma)
+ $,cs6(nlma),cs7(nlma),cs8(nlma),cs9(nlma),cs10(nlma)
+ $,cs11(nlma),cs15(nlma),cs16(nlma)
+ $,cs17(nlma),cs18(nlma),cs19(nlma),cs20(nlma)
+ $,cs21(nlma),cs22(nlma),cs23(nlma),cs24(nlma)
+ complex qim(nrp)
+c
+ do 200 mca=1,ncp
+ m=(mca-1)*minc
+ qim(mca)=ai*float(m)
+ 200 continue
+c
+ do 201 ic=1,ni
+ do 202 mca=1,ncp
+ sc(mca,ic)=0.
+ vrc(mca,ic)=0.
+ vtc(mca,ic)=0.
+ vpc(mca,ic)=0.
+ cvrc(mca,ic)=0.
+ dvrdrc(mca,ic)=0.
+ dvtdrc(mca,ic)=0.
+ dvpdrc(mca,ic)=0.
+ dvrdtc(mca,ic)=0.
+ dvrdpc(mca,ic)=0.
+ dvtdpc(mca,ic)=0.
+ dvpdpc(mca,ic)=0.
+ brc(mca,ic)=0.
+ btc(mca,ic)=0.
+ bpc(mca,ic)=0.
+ cbrc(mca,ic)=0.
+ cbtc(mca,ic)=0.
+ cbpc(mca,ic)=0.
+ 202 continue
+ 201 continue
+c
+ do 203 lm=nlma,2,-1
+ mca=mclma(lm)
+ cs1(lm)=w(lm,kc)*ql(lm,3)
+ cs2(lm)=2.*dw(lm,kc)
+ cs3(lm)=z(lm,kc)*qim(mca)
+ cs4(lm)=2.*dw(lm,kc)*qim(mca)
+ cs5(lm)=-z(lm,kc)
+ cs6(lm)=z(lm,kc)*ql(lm,3)
+ cs7(lm)=2.*dw(lm,kc)*ql(lm,3)
+ cs8(lm)=4.*ddw(lm,kc)
+ cs9(lm)=2.*dz(lm,kc)*qim(mca)
+ cs10(lm)=4.*ddw(lm,kc)*qim(mca)
+ cs11(lm)=-2.*dz(lm,kc)
+ cs15(lm)=b(lm,kc)*ql(lm,3)
+ cs16(lm)=2.*db(lm,kc)
+ cs17(lm)=aj(lm,kc)*qim(mca)
+ cs18(lm)=2.*qim(mca)*db(lm,kc)
+ cs19(lm)=-aj(lm,kc)
+ cs20(lm)=aj(lm,kc)*ql(lm,3)
+ cs21(lm)=2.*dj(lm,kc)
+ cs22(lm)=qim(mca)*(ql(lm,3)*qk(kc,1)*b(lm,kc)-4.*ddb(lm,kc))
+ cs23(lm)=2.*qim(mca)*dj(lm,kc)
+ cs24(lm)=-ql(lm,3)*qk(kc,1)*b(lm,kc)+4.*ddb(lm,kc)
+ 203 continue
+c
+ do 204 ic=1,ni
+ do 204 lm=nlma,2,-1
+ mca=mclma(lm)
+ sc(mca,ic)=sc(mca,ic)+s(lm,kc)*aleg1(lm,ic)
+ vrc(mca,ic)=vrc(mca,ic)+cs1(lm)*aleg1(lm,ic)
+ cvrc(mca,ic)=cvrc(mca,ic)+cs6(lm)*aleg1(lm,ic)
+ dvrdrc(mca,ic)=dvrdrc(mca,ic)+cs7(lm)*aleg1(lm,ic)
+ brc(mca,ic)=brc(mca,ic)+cs15(lm)*aleg1(lm,ic)
+ cbrc(mca,ic)=cbrc(mca,ic)+cs20(lm)*aleg1(lm,ic)
+ 204 continue
+ do 206 ic=1,ni
+ do 206 lm=nlma,2,-1
+ mca=mclma(lm)
+ dvrdtc(mca,ic)=dvrdtc(mca,ic)+cs1(lm)*aleg3(lm,ic)
+ vtc(mca,ic)=vtc(mca,ic)+(cs2(lm)*aleg3(lm,ic)+
+ $ cs3(lm)*aleg1(lm,ic))
+ vpc(mca,ic)=vpc(mca,ic)+(cs4(lm)*aleg1(lm,ic)+
+ $ cs5(lm)*aleg3(lm,ic))
+ dvtdrc(mca,ic)=dvtdrc(mca,ic)+(cs8(lm)*aleg3(lm,ic)+
+ $ cs9(lm)*aleg1(lm,ic))
+ dvpdrc(mca,ic)=dvpdrc(mca,ic)+(cs10(lm)*aleg1(lm,ic)+
+ $ cs11(lm)*aleg3(lm,ic))
+ 206 continue
+ do 208 ic=1,ni
+ do 208 lm=nlma,2,-1
+ mca=mclma(lm)
+ btc(mca,ic)=btc(mca,ic)+(cs17(lm)*aleg1(lm,ic)+
+ $ cs16(lm)*aleg3(lm,ic))
+ bpc(mca,ic)=bpc(mca,ic)+(cs19(lm)*aleg3(lm,ic)+
+ $ cs18(lm)*aleg1(lm,ic))
+ cbtc(mca,ic)=cbtc(mca,ic)+(cs21(lm)*aleg3(lm,ic)+
+ $ cs22(lm)*aleg1(lm,ic))
+ cbpc(mca,ic)=cbpc(mca,ic)+(cs23(lm)*aleg1(lm,ic)+
+ $ cs24(lm)*aleg3(lm,ic))
+ 208 continue
+c
+ do 215 ic=1,ni
+ sc(1,ic)=sc(1,ic)+s(1,kc)*aleg1(1,ic)
+ 215 continue
+c
+ do 220 ic=1,ni
+ do 220 mca=1,nmafa
+ dvrdpc(mca,ic)= qim(mca)*vrc(mca,ic)
+ dvtdpc(mca,ic)=qi(ic,1)*qim(mca)*vtc(mca,ic)
+ dvpdpc(mca,ic)=qi(ic,1)*qim(mca)*vpc(mca,ic)
+ 220 continue
+c
+ return
+ end
Added: 3D/MAG/trunk/src/ludc.f
===================================================================
--- 3D/MAG/trunk/src/ludc.f 2006-06-26 21:27:17 UTC (rev 3892)
+++ 3D/MAG/trunk/src/ludc.f 2006-06-27 00:20:45 UTC (rev 3893)
@@ -0,0 +1,286 @@
+ subroutine ludc
+c
+c contruct matrices for chebychev collocation of linear terms in
+c the governing equations
+c perform LU-decomposition of matrices
+c
+c---------------------------------------------------------------
+ include 'param.f'
+ include 'com1.f'
+ include 'com2.f'
+ include 'com3.f'
+ include 'com4.f'
+ include 'com7.f'
+c---------------------------------------------------------------
+c
+c *** chebyshev collocation, l=0 terms for s and p
+c
+ do 342 nc=1,nn
+ do 343 kc=1,nn
+ s0mat(kc,nc)=(cheb(nc,kc)*oodt-
+ $ alpha*opr*(4.*d2cheb(nc,kc)+
+ $ qk(kc,2)*dcheb(nc,kc)))*anorm*sscl
+ p0mat(kc,nc)=2.*dcheb(nc,kc)*anorm
+ 343 continue
+ 342 continue
+c
+c *** boundary conditions
+c
+ do 351 nc=1,nnaf
+ if(ktops .eq. 1) then
+ s0mat(1,nc)=anorm
+ else
+ s0mat(1,nc)=2.*dcheb(nc,1)*anorm
+ endif
+ if(kbots .eq. 1) then
+ s0mat(nn,nc)=cheb(nc,nn)*anorm
+ else
+ s0mat(nn,nc)=2.*dcheb(nc,nn)*anorm
+ endif
+ p0mat(nps2,nc)=anorm
+ 351 continue
+ if(nnaf .lt. nn) then
+ do 353 nc=nnaf+1,nn
+ s0mat(1,nc)=0.
+ s0mat(nn,nc)=0.
+ p0mat(nps2,nc)=0.
+ 353 continue
+ endif
+c
+c *** normalization
+c
+ do 361 kc=1,nn
+ s0mat(kc,1)=0.5*s0mat(kc,1)
+ s0mat(kc,nn)=0.5*s0mat(kc,nn)
+ p0mat(kc,1)=0.5*p0mat(kc,1)
+ p0mat(kc,nn)=0.5*p0mat(kc,nn)
+ 361 continue
+c
+c *** construct lu decomposed matrices
+c
+ call sgefa(s0mat,nn,nn,is0,info)
+ if(info .ne. 0) stop '28'
+ call sgefa(p0mat,nn,nn,ip0,info)
+ if(info .ne. 0) stop '29'
+c
+c *** chebyshev collocation, l>0 terms for s
+c
+ do 200 l=1,lmax
+c
+ lm=l+1
+c
+ do 242 nc=1,nn
+ do 243 kc=1,nn
+ smat(kc,nc,l)=(cheb(nc,kc)*oodt-
+ $ alpha*opr*(4.*d2cheb(nc,kc)+
+ $ qk(kc,2)*dcheb(nc,kc)-
+ $ ql(lm,3)*qk(kc,1)*cheb(nc,kc)))*anorm*sscl
+ 243 continue
+ 242 continue
+c
+c *** boundary conditions
+c
+ do 251 nc=1,nnaf
+ if(ktops .eq. 1) then
+ smat(1,nc,l)=anorm
+ else
+ smat(1,nc,l)=2.*dcheb(nc,1)*anorm
+ endif
+ if(kbots .eq. 1) then
+ smat(nn,nc,l)=cheb(nc,nn)*anorm
+ else
+ smat(nn,nc,l)=2.*dcheb(nc,nn)*anorm
+ endif
+ 251 continue
+ if(nnaf .lt. nn) then
+ do 253 nc=nnaf+1,nn
+ smat(1,nc,l)=0.
+ smat(nn,nc,l)=0.
+ 253 continue
+ endif
+c
+c *** normalization
+c
+ do 261 kc=1,nn
+ smat(kc,1,l)=0.5*smat(kc,1,l)
+ smat(kc,nn,l)=0.5*smat(kc,nn,l)
+ 261 continue
+c
+c *** construct lu decomposed matrix
+c
+ call sgefa(smat(1,1,l),nn,nn,is(1,l),info)
+ if(info .ne. 0) stop '31'
+c
+ 200 continue
+c
+c *** chebyshev collocation, l>0 terms for magnetic potentials
+c
+ do 400 l=1,lmax
+c
+ lm=l+1
+c
+ do 442 nc=1,nn
+ do 443 kc=1,nn
+ bmat(kc,nc,l)=(oodt*ql(lm,3)*qk(kc,1)*cheb(nc,kc)-
+ $ alpha*ql(lm,11)*opm*qk(kc,1)*
+ $ (4.*d2cheb(nc,kc)-
+ $ ql(lm,3)*qk(kc,1)*cheb(nc,kc)))*anorm*bscl
+ ajmat(kc,nc,l)=(oodt*ql(lm,3)*qk(kc,1)*cheb(nc,kc)-
+ $ alpha*ql(lm,11)*opm*qk(kc,1)*
+ $ (4.*d2cheb(nc,kc)-
+ $ ql(lm,3)*qk(kc,1)*cheb(nc,kc)))*anorm*bscl
+ 443 continue
+ 442 continue
+c
+c *** boundary conditions
+c
+ do 451 nc=1,nnaf
+ bmat(1,nc,l)=((2.*dcheb(nc,1)+float(l)/r(1)*cheb(nc,1))+
+ $ cmb*(4.*d2cheb(nc,1)-float(l*(l+1))/(r(1)*r(1))*
+ $ cheb(nc,1)))*anorm
+ ajmat(1,nc,l)=(2.*cmb*dcheb(nc,1)+cheb(nc,1))*anorm
+ if(kbotb .eq. 2) then
+ bmat(nn1,nc,l)=4.*d2cheb(nc,nn)*anorm
+ ajmat(nn,nc,l)=2.*dcheb(nc,nn)*anorm
+ else
+ bmat(nn,nc,l)=(2.*dcheb(nc,nn)-float(l+1)/r(nn)*
+ $ cheb(nc,nn))*anorm
+ ajmat(nn,nc,l)=cheb(nc,nn)*anorm
+ endif
+ if(l.eq.1.and.imagcon.lt.0) bmat(nn,nc,1)=cheb(nc,nn)*anorm
+ 451 continue
+c
+ if(nnaf .lt. nn) then
+ do 453 nc=nnaf+1,nn
+ bmat(1,nc,l)=0.
+ ajmat(1,nc,l)=0.
+ if(kbotb .eq. 2) then
+ bmat(nn1,nc,l)=0.
+ ajmat(nn,nc,l)=0.
+ else
+ bmat(nn,nc,l)=0.
+ ajmat(nn,nc,l)=0.
+ endif
+ 453 continue
+ endif
+c
+c *** normalization
+c
+ do 461 kc=1,nn
+ bmat(kc,1,l)=0.5*bmat(kc,1,l)
+ bmat(kc,nn,l)=0.5*bmat(kc,nn,l)
+ ajmat(kc,1,l)=0.5*ajmat(kc,1,l)
+ ajmat(kc,nn,l)=0.5*ajmat(kc,nn,l)
+ 461 continue
+c
+c *** lu-decomposition
+c
+ call sgefa(bmat(1,1,l),nn,nn,ib(1,l),info)
+ if(info .ne. 0) stop '32'
+ call sgefa(ajmat(1,1,l),nn,nn,ij(1,l),info)
+ if(info .ne. 0) stop '33'
+ 400 continue
+c
+c *** chebycheff collocation, l>0 terms for velocity potentials
+c
+ do 500 l=1,lmax
+c
+ lm=l+1
+c
+ do 542 nc=1,nn
+ nd=nc+nn
+ do 543 kc=1,nn
+ kd=kc+nn
+ zmat(kc,nc,l)=(oodt*ql(lm,3)*qk(kc,1)*cheb(nc,kc)-
+ $ alpha*ql(lm,12)*qk(kc,1)*
+ $ (4.*d2cheb(nc,kc)-
+ $ (ql(lm,3)*qk(kc,1))*cheb(nc,kc)))*anorm*zscl
+ wpmat(kc,nc,l)=(oodt*ql(lm,3)*qk(kc,1)*cheb(nc,kc)-
+ $ alpha*ql(lm,12)*qk(kc,1)*
+ $ (4.*d2cheb(nc,kc)-
+ $ (ql(lm,3)*qk(kc,1))*cheb(nc,kc)))*
+ $ anorm*wscl
+ wpmat(kc,nd,l)=alpha*(2.*dcheb(nc,kc))*anorm*pscl
+ wpmat(kd,nc,l)=(-2.*oodt*ql(lm,3)*qk(kc,1)*dcheb(nc,kc)-
+ $ alpha*ql(lm,12)*qk(kc,1)*
+ $ (-8.*d3cheb(nc,kc)+
+ $ 2.*(ql(lm,3)*qk(kc,1))*dcheb(nc,kc)-
+ $ ql(lm,3)*qk(kc,5)*cheb(nc,kc)))*anorm*wscl
+ wpmat(kd,nd,l)=-alpha*ql(lm,3)*qk(kc,1)*cheb(nc,kc)*anorm*
+ $ pscl
+ 543 continue
+ 542 continue
+c
+c *** boundary conditions
+c
+ do 551 nc=1,nnaf
+ nd=nc+nn
+ wpmat(1,nc,l)=cheb(nc,1)*anorm
+ wpmat(1,nd,l)=0.
+ wpmat(nn,nc,l)=cheb(nc,nn)*anorm
+ wpmat(nn,nd,l)=0.
+ if(ktopv.eq.1) then
+ zmat(1,nc,l)=(2.*dcheb(nc,1)-
+ $ qk(1,6)*cheb(nc,1))*anorm
+ wpmat(nnp1,nc,l)=(4.*d2cheb(nc,1)-
+ $ 2.*dcheb(nc,1)*qk(1,6))*anorm
+ else
+ zmat(1,nc,l)=cheb(nc,1)*anorm
+ wpmat(nnp1,nc,l)=2.*dcheb(nc,1)*anorm
+ endif
+ wpmat(nnp1,nd,l)=0.
+ if(kbotv.eq.1) then
+ zmat(nn,nc,l)=(2.*dcheb(nc,nn)-
+ $ qk(nn,6)*cheb(nc,nn))*anorm
+ wpmat(nnx2,nc,l)=(4.*d2cheb(nc,nn)-
+ $ 2.*qk(nn,6)*dcheb(nc,nn))*anorm
+ else
+ zmat(nn,nc,l)=cheb(nc,nn)*anorm
+ wpmat(nnx2,nc,l)=2.*dcheb(nc,nn)*anorm
+ endif
+ wpmat(nnx2,nd,l)=0.
+ 551 continue
+c
+ if(nnaf .lt. nn) then
+ do 553 nc=nnaf+1,nn
+ nd=nc+nn
+ wpmat(1,nc,l)=0.
+ wpmat(1,nd,l)=0.
+ wpmat(nn,nc,l)=0.
+ wpmat(nn,nd,l)=0.
+ zmat(1,nc,l)=0.
+ wpmat(nnp1,nc,l)=0.
+ wpmat(nnp1,nd,l)=0.
+ zmat(nn,nc,l)=0.
+ wpmat(nnx2,nc,l)=0.
+ wpmat(nnx2,nd,l)=0.
+ 553 continue
+ endif
+c
+c *** normalization
+c
+ do 561 kc=1,nn
+ kd=kc+nn
+ zmat(kc,1,l)=0.5*zmat(kc,1,l)
+ zmat(kc,nn,l)=0.5*zmat(kc,nn,l)
+ wpmat(kc,1,l)=0.5*wpmat(kc,1,l)
+ wpmat(kc,nn,l)=0.5*wpmat(kc,nn,l)
+ wpmat(kc,nnp1,l)=0.5*wpmat(kc,nnp1,l)
+ wpmat(kc,nnx2,l)=0.5*wpmat(kc,nnx2,l)
+ wpmat(kd,1,l)=0.5*wpmat(kd,1,l)
+ wpmat(kd,nn,l)=0.5*wpmat(kd,nn,l)
+ wpmat(kd,nnp1,l)=0.5*wpmat(kd,nnp1,l)
+ wpmat(kd,nnx2,l)=0.5*wpmat(kd,nnx2,l)
+ 561 continue
+c
+c *** lu-decomposition of matrices
+c
+ call sgefa(zmat(1,1,l),nn,nn,iz(1,l),info)
+ if(info .ne. 0) stop '34'
+ call sgefa(wpmat(1,1,l),nnx2,nnx2,iwp(1,l),info)
+ if(info .ne. 0) stop '35'
+c
+ 500 continue
+c
+ return
+ end
Added: 3D/MAG/trunk/src/makefile
===================================================================
--- 3D/MAG/trunk/src/makefile 2006-06-26 21:27:17 UTC (rev 3892)
+++ 3D/MAG/trunk/src/makefile 2006-06-27 00:20:45 UTC (rev 3893)
@@ -0,0 +1,81 @@
+ magx : nl.o prep.o amhd.o legtf.o rderiv.o stor.o prnt.o ludc.o dtchck.o kei.o mei.o pbar.o gquad.o random.o chebtf.o chebi.o rffti.o fact.o cftrig.o fourtf.o fax.o fftrig.o sgesl.o sgefa.o fft99a.o fft99b.o vpassm.o wpassm.o spherictf.o filter.o graphout.o moveout.o movaout.o movmout.o cmbcoeff.o spectrum.o mapdata.o copydat.o stopiteration.o
+ g77 nl.o prep.o amhd.o legtf.o rderiv.o stor.o prnt.o ludc.o dtchck.o kei.o mei.o pbar.o gquad.o random.o chebtf.o chebi.o rffti.o fact.o cftrig.o fourtf.o fax.o fftrig.o sgesl.o sgefa.o fft99a.o fft99b.o vpassm.o wpassm.o spherictf.o filter.o graphout.o moveout.o movaout.o movmout.o cmbcoeff.o spectrum.o mapdata.o copydat.o stopiteration.o -o magx32s4
+nl.o : nl.f param.f com3.f com8.f
+ g77 -O2 -funroll-all-loops -c -C nl.f
+prep.o : prep.f param.f com1.f com2.f com3.f com4.f com5.f com6.f com7.f com8.f
+ g77 -O2 -funroll-all-loops -c -C prep.f
+amhd.o : amhd.f param.f com1.f com2.f com3.f com4.f com5.f com6.f com7.f com8.f
+ g77 -O2 -funroll-all-loops -c -C amhd.f
+legtf.o : legtf.f param.f com4.f com5.f com6.f
+ g77 -O2 -funroll-all-loops -c -C legtf.f
+rderiv.o : rderiv.f param.f com7.f
+ g77 -O2 -funroll-all-loops -c -C rderiv.f
+dtchck.o : dtchck.f
+ g77 -O2 -funroll-all-loops -c -C dtchck.f
+kei.o : kei.f param.f com1.f com4.f com5.f
+ g77 -O2 -funroll-all-loops -c -C kei.f
+mei.o : mei.f param.f com1.f com4.f com5.f
+ g77 -O2 -funroll-all-loops -c -C mei.f
+pbar.o : pbar.f
+ g77 -O2 -funroll-all-loops -c -C pbar.f
+ludc.o : ludc.f param.f com1.f com2.f com3.f com4.f com7.f
+ g77 -O2 -funroll-all-loops -c -C ludc.f
+gquad.o : gquad.f
+ g77 -O2 -funroll-all-loops -c -C gquad.f
+random.o : random.f
+ g77 -O2 -funroll-all-loops -c -C random.f
+chebtf.o : chebtf.f
+ g77 -O2 -funroll-all-loops -c -C chebtf.f
+chebi.o : chebi.f
+ g77 -O2 -funroll-all-loops -c -C chebi.f
+rffti.o : rffti.f
+ g77 -O2 -funroll-all-loops -c -C rffti.f
+fact.o : fact.f
+ g77 -O2 -funroll-all-loops -c -C fact.f
+cftrig.o : cftrig.f
+ g77 -O2 -funroll-all-loops -c -C cftrig.f
+fourtf.o : fourtf.f
+ g77 -O2 -funroll-all-loops -c -C fourtf.f
+fax.o : fax.f
+ g77 -O2 -funroll-all-loops -c -C fax.f
+fftrig.o : fftrig.f
+ g77 -O2 -funroll-all-loops -c -C fftrig.f
+sgesl.o : sgesl.f
+ g77 -O2 -funroll-all-loops -c -C sgesl.f
+sgefa.o : sgefa.f
+ g77 -O2 -funroll-all-loops -c -C sgefa.f
+fft99a.o : fft99a.f
+ g77 -O2 -funroll-all-loops -c -C fft99a.f
+fft99b.o : fft99b.f
+ g77 -O2 -funroll-all-loops -c -C fft99b.f
+vpassm.o : vpassm.f
+ g77 -O2 -funroll-all-loops -c -C vpassm.f
+wpassm.o : wpassm.f
+ g77 -O2 -funroll-all-loops -c -C wpassm.f
+spherictf.o : spherictf.f param.f com4.f
+ g77 -O2 -funroll-all-loops -c -C spherictf.f
+filter.o : filter.f param.f com4.f
+ g77 -O2 -funroll-all-loops -c -C filter.f
+graphout.o : graphout.f param.f com1.f com3.f com4.f com5.f com6.f com8.f
+ g77 -O2 -funroll-all-loops -c -C graphout.f
+moveout.o : moveout.f param.f com1.f com3.f com4.f com6.f com8.f
+ g77 -O2 -funroll-all-loops -c -C moveout.f
+movaout.o : movaout.f param.f com1.f com3.f com4.f com6.f com8.f
+ g77 -O2 -funroll-all-loops -c -C movaout.f
+movmout.o : movmout.f param.f com1.f com3.f com4.f com6.f com8.f
+ g77 -O2 -funroll-all-loops -c -C movmout.f
+cmbcoeff.o : cmbcoeff.f param.f com1.f com3.f com5.f com8.f
+ g77 -O2 -funroll-all-loops -c -C cmbcoeff.f
+spectrum.o : spectrum.f param.f com1.f com3.f com4.f com5.f com8.f
+ g77 -O2 -funroll-all-loops -c -C spectrum.f
+stor.o : stor.f param.f com1.f com3.f com4.f com5.f
+ g77 -O2 -funroll-all-loops -c -C stor.f
+prnt.o : prnt.f param.f com1.f com3.f com4.f com5.f com8.f
+ g77 -O2 -funroll-all-loops -c -C prnt.f
+mapdata.o : mapdata.f param.f com3.f com5.f
+ g77 -O2 -funroll-all-loops -c -C mapdata.f
+copydat.o : copydat.f
+ g77 -O2 -funroll-all-loops -c -C copydat.f
+stopiteration.o : stopiteration.f
+ g77 -O2 -funroll-all-loops -c -C stopiteration.f
+
Added: 3D/MAG/trunk/src/mapdata.f
===================================================================
--- 3D/MAG/trunk/src/mapdata.f 2006-06-26 21:27:17 UTC (rev 3892)
+++ 3D/MAG/trunk/src/mapdata.f 2006-06-27 00:20:45 UTC (rev 3893)
@@ -0,0 +1,118 @@
+ subroutine mapdata(nnold,niold,njold,minco)
+c
+c---------------------------------------------------------------
+c
+c map data from input file with different grid structure in the
+c angular variables or different longitudinal symmetry (urc)
+c
+c called in prep
+c
+c
+ include 'param.f'
+ parameter (nn32=3*nnp1/2)
+ parameter (noldsize=3*nlma*nnp1)
+ include 'com1.f'
+ include 'com3.f'
+ include 'com4.f'
+ include 'com5.f'
+
+ complex wo(noldsize),zo(noldsize),po(noldsize),so(noldsize)
+ dimension rold(nn32)
+ equivalence (wo,dw),(zo,dz),(po,db),(so,aleg1)
+c
+ if(mod(minco,minc).ne.0)
+ $ write(6,'('' Warning: Incompatible minc/minco= '',2i3)')
+c
+ nnop1=nnold+1
+ lmaxo= njold/3
+ mmaxo= (lmaxo/minco) * minco
+ nlmao= mmaxo*(lmaxo+1)/minco -mmaxo*(mmaxo-minco)/(2*minco)
+ & +lmaxo-mmaxo+1
+ ndata1=nlmao*nnop1
+ ndata=nlmao*nnold
+ if(nnold.gt.nn32) then
+ write(6,'('' nnold='',i3,'' too large'')') nnold
+ stop '54'
+ endif
+ if(ndata1.gt.3*nlma*nnp1) then
+ write(6,'('' Old data set is too large '')')
+ write(6,'('' New/Old Lmax= '',2I4,'' Mmax= '',2i4,
+ & '' Minc= '',2i3,'' Nr= '',2i3)')
+ & lmax,lmaxo,mmax,mmaxo,minc,minco,nn,nnold
+ write(6,'('' Total old data > 3* new data !'')')
+ stop '47'
+ endif
+ if(nn.ne.nnold) then
+ pik=pi/float(nnold-1)
+ do kco=1,nnold
+ rold(kco)=radbot+0.5*(1.+cos(float(kco-1)*pik))
+ enddo
+ endif
+c
+ write(6,'(/'' Mapping data on different grid '')')
+ write(6,'('' Old/New Lmax= '',2I4,'' Mmax= '',2I4,
+ $ '' Minc= '',2I3,'' Nlma= '',2I5/)') lmaxo,lmax,mmaxo,
+ $ mmax,minco,minc,nlmao,nlma
+ if(nnold.ne.nn) write(6,'('' Old/New nn='',2i4)') nnold,nn
+c
+c read and copy data for w,z,p,s
+c
+ read(8) (wo(i),i=1,ndata1),
+ & (zo(i),i=1,ndata1),
+ & (po(i),i=1,ndata1),
+ & (so(i),i=1,ndata1)
+c
+ call copydat(w,wo,nlma,nlmao,lmax,lmaxo,mmax,mmaxo,minc,minco,
+ $ nnp1,nnop1,nnp1,nn32,r,rold)
+ call copydat(z,zo,nlma,nlmao,lmax,lmaxo,mmax,mmaxo,minc,minco,
+ $ nnp1,nnop1,nnp1,nn32,r,rold)
+ call copydat(p,po,nlma,nlmao,lmax,lmaxo,mmax,mmaxo,minc,minco,
+ $ nnp1,nnop1,nnp1,nn32,r,rold)
+ call copydat(s,so,nlma,nlmao,lmax,lmaxo,mmax,mmaxo,minc,minco,
+ $ nnp1,nnop1,nnp1,nn32,r,rold)
+c
+c read and copy data for dsdt1,dwdt1,dzdt1,dpdt1
+c
+ read(8) (so(i),i=1,ndata),
+ & (wo(i),i=1,ndata),
+ & (zo(i),i=1,ndata),
+ & (po(i),i=1,ndata)
+c
+ call copydat(dsdt1,so,nlma,nlmao,lmax,lmaxo,mmax,mmaxo,minc,minco,
+ $ nn,nnold,nnp1,nn32,r,rold)
+ call copydat(dwdt1,wo,nlma,nlmao,lmax,lmaxo,mmax,mmaxo,minc,minco,
+ $ nn,nnold,nnp1,nn32,r,rold)
+ call copydat(dzdt1,zo,nlma,nlmao,lmax,lmaxo,mmax,mmaxo,minc,minco,
+ $ nn,nnold,nnp1,nn32,r,rold)
+ call copydat(dpdt1,po,nlma,nlmao,lmax,lmaxo,mmax,mmaxo,minc,minco,
+ $ nn,nnold,nnp1,nn32,r,rold)
+c
+c read and copy data for b, aj, dbdt1,djdt1
+c
+ if(init.ne.0) return
+c
+ read(8) (so(i),i=1,ndata1),
+ & (wo(i),i=1,ndata1),
+ & (zo(i),i=1,ndata),
+ & (po(i),i=1,ndata)
+c
+ call copydat(b,so,nlma,nlmao,lmax,lmaxo,mmax,mmaxo,minc,minco,
+ $ nnp1,nnop1,nnp1,nn32,r,rold)
+ call copydat(aj,wo,nlma,nlmao,lmax,lmaxo,mmax,mmaxo,minc,minco,
+ $ nnp1,nnop1,nnp1,nn32,r,rold)
+ call copydat(dbdt1,zo,nlma,nlmao,lmax,lmaxo,mmax,mmaxo,minc,minco,
+ $ nn,nnold,nnp1,nn32,r,rold)
+ call copydat(djdt1,po,nlma,nlmao,lmax,lmaxo,mmax,mmaxo,minc,minco,
+ $ nn,nnold,nnp1,nn32,r,rold)
+c
+c if starting from data file with longitudinal symmetry, add
+c weak non-axisymmetric dipole component
+c
+ if(minc.gt.1 .or. minco.eq.1 .or. tipdipole.eq.0.0) return
+c
+ do kc=1,nnp1
+ b(lmax+2,kc)=0.707106781*tipdipole*b(2,kc)
+ enddo
+c
+ return
+ end
Added: 3D/MAG/trunk/src/mei.f
===================================================================
--- 3D/MAG/trunk/src/mei.f 2006-06-26 21:27:17 UTC (rev 3892)
+++ 3D/MAG/trunk/src/mei.f 2006-06-27 00:20:45 UTC (rev 3893)
@@ -0,0 +1,74 @@
+ subroutine mei(enbp,enbt,apome,atome)
+c
+c calculates total magnetic energy = 1/2 Integral(B^2 dV)
+c
+c---------------------------------------------------------------
+ include 'param.f'
+ include 'com1.f'
+ include 'com4.f'
+ include 'com5.f'
+c
+ complex c
+ cabssq(c)=real(c)**2+aimag(c)**2
+c---------------------------------------------------------------
+c
+ do 20 kc=1,nn
+ rvap(kc)=0.
+ rvat(kc)=0.
+ rvb(kc)=0.
+ rvc(kc)=0.
+ 20 continue
+c
+ do 30 lm=nlma,2,-1
+ do 31 kc=1,nn
+ rvap(kc)=rvap(kc)+
+ $ ql(lm,6)*(ql(lm,3)*qk(kc,1)*cabssq(b(lm,kc))
+ $ +4.*cabssq(db(lm,kc)))
+ rvat(kc)=rvat(kc)+ql(lm,6)*cabssq(aj(lm,kc))
+ 31 continue
+ 30 continue
+c
+ do 35 lm=nlaf,2,-1
+ do 36 kc=1,nn
+ rvb(kc)=rvb(kc)+ql(lm,6)*cabssq(aj(lm,kc))
+ rvc(kc)=rvc(kc)+
+ $ ql(lm,6)*(ql(lm,3)*qk(kc,1)*cabssq(b(lm,kc))+
+ $ 4.*cabssq(db(lm,kc)))
+ 36 continue
+ 35 continue
+c
+ call chebtf(1,ns2,1,nn1,ns2,rvap,rvap,rvap,wsave,
+ $work,work(2,1),work(2,1),work(2,1),trigsc,ifaxc,k2k)
+ call chebtf(1,ns2,1,nn1,ns2,rvat,rvat,rvat,wsave,
+ $work,work(2,1),work(2,1),work(2,1),trigsc,ifaxc,k2k)
+ call chebtf(1,ns2,1,nn1,ns2,rvb,rvb,rvb,wsave,
+ $work,work(2,1),work(2,1),work(2,1),trigsc,ifaxc,k2k)
+ call chebtf(1,ns2,1,nn1,ns2,rvc,rvc,rvc,wsave,
+ $work,work(2,1),work(2,1),work(2,1),trigsc,ifaxc,k2k)
+c
+ enbp=0.
+ enbt=0.
+ atome=0.
+ apome=0.
+ rvap(1)=0.5*rvap(1)
+ rvap(nn)=0.5*rvap(nn)
+ rvat(1)=0.5*rvat(1)
+ rvat(nn)=0.5*rvat(nn)
+ rvb(1)=0.5*rvb(1)
+ rvb(nn)=0.5*rvb(nn)
+ rvc(1)=0.5*rvc(1)
+ rvc(nn)=0.5*rvc(nn)
+ do 50 ncb=1,nn,2
+ nc=nnp1-ncb
+ enbp=enbp+rvap(nc)*qn(nc,3)
+ enbt=enbt+rvat(nc)*qn(nc,3)
+ atome=atome+rvb(nc)*qn(nc,3)
+ apome=apome+rvc(nc)*qn(nc,3)
+ 50 continue
+ enbp= 0.5*oekpm*anorm*enbp
+ enbt= 0.5*oekpm*anorm*enbt
+ atome=0.5*oekpm*anorm*atome
+ apome=0.5*oekpm*anorm*apome
+c
+ return
+ end
Added: 3D/MAG/trunk/src/movaout.f
===================================================================
--- 3D/MAG/trunk/src/movaout.f 2006-06-26 21:27:17 UTC (rev 3892)
+++ 3D/MAG/trunk/src/movaout.f 2006-06-27 00:20:45 UTC (rev 3893)
@@ -0,0 +1,135 @@
+ subroutine movaout(kc)
+c
+c supplied by urc
+c
+c called in nl and amhd
+c
+c output of longitudinally averaged B_phi, j_phi, and v_phi
+c for procuding movie
+c for kc=0 a header is written
+c for kc>0 values at radial level kc are written
+c
+ include 'param.f'
+ include 'com1.f'
+ include 'com3.f'
+ include 'com4.f'
+ include 'com6.f'
+ include 'com8.f'
+c
+ dimension vp(nrp,ni)
+ dimension bp(nrp,ni),bt(nrp,ni),br(nrp,ni)
+c
+ dimension bpa(ni),bta(ni),bra(ni),vpa(ni)
+ dimension ajp(ni)
+c
+ equivalence (vp,vpc)
+ equivalence (bp,bpc),(bt,btc),(br,brc)
+c
+ if(kc.gt.0) go to 300
+c
+c write header
+c
+ write(19,'(A64)') runid
+c
+ write(19,'(2e13.5)') tscale,vscale
+ write(19,'(5i6)') nn,ni,nj,minc,iframes
+c
+c write radii and colatitudes
+c
+ write(19,'(65(1x,f8.5))') (r(ir)/radtop,ir=1,nn)
+ write(19,'(65(1x,f8.5))') (qi(ic,5),ic=1,ni)
+ return
+c
+c calculate averages
+c
+ 300 do ic=1,ni
+ bpa(ic)=0.0
+ bta(ic)=0.0
+ bra(ic)=0.0
+ vpa(ic)=0.0
+ do jc=1,nja
+ bpa(ic)=bpa(ic)+bp(ic,jc)
+ bta(ic)=bta(ic)+bt(ic,jc)
+ bra(ic)=bra(ic)+br(ic,jc)
+ vpa(ic)=vpa(ic)+vp(ic,jc)
+ enddo
+ bpa(ic)=bpa(ic)/real(nja) *qk(kc,3)/qi(ic,3)
+ bta(ic)=bta(ic)/real(nja) *qk(kc,3)/qi(ic,3)
+ bra(ic)=bra(ic)/real(nja) *qk(kc,1)
+ vpa(ic)=vpa(ic)/real(nja) *qk(kc,3)/qi(ic,3)
+ enddo
+c
+c calculate phi-component of curl(B) for radius kc-1
+c
+ kup=mod(kc+1,3)+1
+ kmd=mod(kc+2,3)+1
+ klw=mod(kc+3,3)+1
+ do ic=1,ni
+ bts(ic,klw)=bta(ic)
+ enddo
+c
+ if(kc.eq.1) go to 320
+ if(kc.eq.2) then
+ do ic=1,ni
+ ajp(ic) = -brdt(ic)
+ & + (bts(ic,kmd)-bts(ic,klw))/(r(1)-r(2))
+ & + bts(ic,kmd)/r(1)
+ enddo
+ go to 320
+ endif
+c
+c kc > 2
+c
+ drup=r(kc-2)-r(kc-1)
+ drlw=r(kc-1)-r(kc)
+ frlw=-drup/(drlw*(drlw+drup))
+ frmd=(drup-drlw)/(drup*drlw) + 1./r(kc-1)
+ frup= drlw/(drup*(drlw+drup))
+ do ic=1,ni
+ ajp(ic)= -brdt(ic)
+ & +bts(ic,klw)*frlw+bts(ic,kmd)*frmd+bts(ic,kup)*frup
+ enddo
+c
+ 320 do ic=2,ni-1
+ brdt(ic)=(bra(ic+1)-bra(ic-1))/
+ & (r(kc)*(qi(ic+1,5)-qi(ic-1,5)))
+ enddo
+ brdt(1)=(bra(2)-bra(1))/
+ & (r(kc)*(qi(2,5)-qi(1,5)))
+ brdt(ni)=(bra(ni)-bra(ni-1))/
+ & (r(kc)*(qi(ni,5)-qi(ni-1,5)))
+c
+ if(kc.eq.1) then
+ write(19,'(I5,1x,f8.5)') imovct,time/tscale
+ else
+c
+c write j_phi for level kc-1
+c
+ write(19,900) (ajp(jc),ic=1,ni)
+ endif
+c
+c write v_phi
+c
+ write(19,902) (vpa(ic)/vscale,ic=1,ni)
+c
+c write b_phi
+c
+ write(19,901) (bpa(ic),ic=1,ni)
+c
+ if(kc.lt.nn) return
+c
+c calculate and write j_phi for final radius kc=nn
+c
+ do ic=1,ni
+ ajp(ic)= -brdt(ic)
+ & + (bts(ic,kmd)-bts(ic,klw))/(r(nn-1)-r(nn))
+ & + bts(ic,klw)/r(nn)
+ enddo
+ write(19,900) (ajp(ic),ic=1,ni)
+c
+ 900 format(256(1X,f7.2))
+ 901 format(256(1X,f7.4))
+ 902 format(256(1X,f7.3))
+c
+ return
+ end
Added: 3D/MAG/trunk/src/moveout.f
===================================================================
--- 3D/MAG/trunk/src/moveout.f 2006-06-26 21:27:17 UTC (rev 3892)
+++ 3D/MAG/trunk/src/moveout.f 2006-06-27 00:20:45 UTC (rev 3893)
@@ -0,0 +1,129 @@
+ subroutine moveout(kc)
+c
+c supplied by urc
+c
+c called in nl and amhd
+c
+c output of entropy, z-vorticity, and z-field in equatorial plane
+c for procuding movie
+c for kc=0 a header is written
+c for kc>0 values at radial level kc are written
+c
+ include 'param.f'
+ include 'com1.f'
+ include 'com3.f'
+ include 'com4.f'
+ include 'com6.f'
+ include 'com8.f'
+c
+ dimension vr(nrp,ni),vp(nrp,ni)
+ dimension bt(nrp,ni)
+ dimension sr(nrp,ni)
+c
+ dimension ur(0:nja+1),wz(nja)
+c
+ equivalence (vr,vrc),(vp,vpc)
+ equivalence (bt,btc)
+ equivalence (sr,sc)
+c
+ if(kc.gt.0) go to 300
+c
+c write header
+c
+ write(18,'(A64)') runid
+c
+ write(18,'(2e13.5)') tscale,vscale
+ write(18,'(5i6)') nn,ni,nj,minc,iframes
+c
+c write radii
+c
+ write(18,'(65(1x,f8.5))') (r(ir)/radtop,ir=1,nn)
+ return
+c
+c output for radial levels
+c
+ 300 iequat=ni/2
+ dphi2=16.*atan(1.)/real(nj)
+c
+c calculate z-vorticity
+c
+ kup=mod(kc+1,3)+1
+ kmd=mod(kc+2,3)+1
+ klw=mod(kc+3,3)+1
+ do jc=1,nja
+ up(jc,klw)=vp(jc,iequat)*qk(kc,3)
+ ur(jc)= vr(jc,iequat)*qk(kc,1)
+ enddo
+ ur(0)=ur(nja)
+ ur(nja+1)=ur(1)
+c
+ if(kc.eq.1) go to 320
+ if(kc.eq.2) then
+ if(ktopv.eq.1) then
+ do jc=1,nja
+ wz(jc)=0.0
+ enddo
+ else
+ do jc=1,nja
+ wz(jc) =
+ & + (up(jc,kmd)-up(jc,klw))/(r(1)-r(2))
+ enddo
+ endif
+ go to 320
+ endif
+c
+c kc > 2
+c
+ drup=r(kc-2)-r(kc-1)
+ drlw=r(kc-1)-r(kc)
+ frlw=-drup/(drlw*(drlw+drup))
+ frmd=(drup-drlw)/(drup*drlw) + 1./r(kc-1)
+ frup= drlw/(drup*(drlw+drup))
+ do jc=1,nja
+ wz(jc)= -urdp(jc)
+ & +up(jc,klw)*frlw+up(jc,kmd)*frmd+up(jc,kup)*frup
+ enddo
+c
+ 320 do jc=1,nja
+ urdp(jc)=(ur(jc+1)-ur(jc-1))/(dphi2*r(kc))
+ enddo
+c
+ if(kc.eq.1) then
+ write(18,'(I5,1x,f8.5)') imovct,time/tscale
+ else
+c
+c write vorticity for level kc-1
+c
+ write(18,900) (wz(jc)/vscale,jc=1,nja)
+ endif
+c
+c write entropy
+c
+ write(18,901) (sr(jc,iequat),jc=1,nja)
+c
+c calculate and write z-field
+c
+ write(18,902) (bt(jc,iequat)*qk(kc,3),jc=1,nja)
+c
+ if(kc.lt.nn) return
+c
+c calculate and write z-vorticity for final radius kc=nn
+c
+ if(kbotv.eq.1) then
+ do jc=1,nja
+ wz(jc)=0.0
+ enddo
+ else
+ do jc=1,nja
+ wz(jc)=
+ & + (up(jc,kmd)-up(jc,klw))/(r(nn-1)-r(nn))
+ enddo
+ endif
+ write(18,900) (wz(jc)/vscale,jc=1,nja)
+c
+ 900 format(256(1X,f7.1))
+ 901 format(256(1X,f7.4))
+ 902 format(256(1X,f7.3))
+c
+ return
+ end
Added: 3D/MAG/trunk/src/movmout.f
===================================================================
--- 3D/MAG/trunk/src/movmout.f 2006-06-26 21:27:17 UTC (rev 3892)
+++ 3D/MAG/trunk/src/movmout.f 2006-06-27 00:20:45 UTC (rev 3893)
@@ -0,0 +1,87 @@
+ subroutine movmout(kc,kc0)
+c
+c called in nl and amhd
+c
+c supplied by urc
+c
+c output of v_r at mid-depth, and B_r at mid-depth and the top
+c surface for producing movie
+c for kc=0 a header is written
+c for kc>0 values at radial level kc are written
+c
+ include 'param.f'
+ include 'com1.f'
+ include 'com3.f'
+ include 'com4.f'
+ include 'com5.f'
+ include 'com6.f'
+ include 'com8.f'
+c
+ dimension vr(nrp,ni)
+ dimension vp(nrp,ni)
+ dimension vt(nrp,ni)
+ dimension br(nrp,ni)
+ dimension brf(nrp,ni)
+c
+ double complex brfc(ncp,ni),blm(nlma)
+c
+ equivalence (vr,vrc)
+ equivalence (vp,vpc)
+ equivalence (vt,vtc)
+ equivalence (br,brc)
+ equivalence (brf,brfc)
+c
+ if(kc.eq.0) then
+c
+c write header
+c
+ ndat=3
+ if(kc0.eq.9) ndat=1
+ write(20,'(A64)') runid
+c
+ write(20,'(2e13.5)') tscale,vscale
+ write(20,'(8i6)') nn,ni,nj,minc,iframes,ndat,nglon,ngcolat
+c
+c write colatitudes
+c
+ write(20,'(128(1x,f8.5))') (qi(ic,5),ic=1,ni,ngcolat)
+ return
+c
+c output of B_r at outer surface
+c
+ else if (kc.eq.1) then
+ write(20,'(I5,1x,f9.6)') imovct,time/tscale
+ if(nfilt.le.0) then
+ do ic=1,ni,ngcolat
+ write(20,901) (br(jc,ic)*qk(1,1),jc=1,nja,nglon)
+ enddo
+ else
+ call filter(b,blm,1,alfilt,nfilt,dipfilt)
+ call spherictf(blm,brfc)
+ do ic=1,ni,nglon
+ write(20,901) (brf(jc,ic)*qk(1,1),jc=1,nja,nglon)
+ enddo
+ endif
+c
+c output of phi-component of velocity at level kc0
+c
+ endif
+ if(kc0.eq.9) return
+ if (kc.eq.kc0) then
+ do ic=1,ni,ngcolat
+ write(20,902) (vp(jc,ic)*qk(kc0,3)/(qi(ic,3)*vscale),
+ & jc=1,nja,nglon)
+ enddo
+ do ic=1,ni,ngcolat
+ write(20,902) (vt(jc,ic)*qk(kc0,3)/(qi(ic,3)*vscale),
+ & jc=1,nja,nglon)
+ enddo
+ endif
+c
+ return
+c
+ 900 format(256(1X,f7.1))
+ 901 format(256(1X,f7.4))
+ 902 format(256(1X,f7.2))
+c
+ end
Added: 3D/MAG/trunk/src/nl.f
===================================================================
--- 3D/MAG/trunk/src/nl.f 2006-06-26 21:27:17 UTC (rev 3892)
+++ 3D/MAG/trunk/src/nl.f 2006-06-27 00:20:45 UTC (rev 3893)
@@ -0,0 +1,197 @@
+ program nl
+c
+c A dynamic dynamo model driven by thermal convection
+c in a rotating spherical fluid shell.
+c This version is restricted to Boussinesq fluids and
+c non-dimensional variables are used throughout.
+c
+c The following set of equations is solved:
+c
+c E {dv/dt + v.grad(v)} = -grad(p) - 2e_z x v
+c +1/Pm rot(B) x B + RaE/Pr g/g_o T
+c
+c dB/dt = rot(v x B) + 1/Pm Lapl(B)
+c
+c dT/dt + v.grad(T) = 1/Pr Lapl(T) + epsc0
+c
+c div(v)=0 div(B)=0
+c
+c subject to the following boundary conditions
+c at the inner and outer radii:
+c
+c v_r=0, and either no slip or stress free
+c T=0 / T=1 or fixed heat flux (the latter not tested!)
+c B fitted to exterior potential fields, or parts of B
+c specified on the boundaries
+c
+c List of symbols:
+c
+c v: velocity p: pressure B: magnetic field
+c g: gravity g_o: reference value at outer radius
+c T: temperature epsc0: rate of internal heating
+c e_z: unit vector parallel to the rotation axis
+c d/dt: partial time derivative Lapl: Laplace operator
+c
+c Scaling properties:
+c
+c nu: kinematic viscosity d: shell width
+c omega: angular frequency alpha: thermal expansion coeff
+c delta_T: temperature contrast kappa: thermal diffusivity
+c eta: magnetic diffusivity rho: density
+c mu_o: magnetic permeability
+c
+c Scaling:
+c
+c Length: d time: d^2/nu
+c Velocity: nu/d pressure: rho*nu*omega
+c Temperature: delta_T mag.field: sqrt(rho*mu_o*eta*omega)
+c
+c
+c Non-dimensional numbers:
+c
+c E: Ekman number E= nu*d^2/omega
+c Ra: Rayleigh number Ra = alpha*g_o*delta_T*d^3/(kappa*nu)
+c Pr: Prandtl number Pr = nu/kappa
+c Pm: Magnetic Prandtl number Pm=nu/eta
+c
+c
+c
+c
+c Numerical simulations via a nonlinear, multimode,
+c initial-boundary value problem.
+c
+c *** entropy boundary condtions (tops and bots on input)
+c if ktops = 1, entropy specified on outer boundary
+c if ktops = 2, radial heat flux specified on outer boundary
+c if kbots = 1, entropy specified on inner boundary
+c if kbots = 2, radial heat flux specified on inner boundary
+c for example: ktops=1,
+c the spherically-symmetric temperature
+c on the outer boundary relative to the reference state
+c
+c *** velocity boundary condtions
+c if ktopv = 1, stress-free outer boundary
+c if ktopv = 2, non-slip outer boundary
+c if kbotv = 1, stress-free inner boundary
+c if kbotv = 2, non-slip inner boundary
+c
+c *** magnetic boundary condtions
+c if ktopb = 1, insulating outer boundary (mag coupling if cmb.gt.0)
+c if kbotb = 1, perfectly insulating inner boundary
+c if kbotb = 2, perfectly conducting inner boundary
+c
+c *** magneto-convection
+c bpeak = max amplitude of imposed magnetic field
+c if imagcon .eq. 1, imposed toroidal field via inner bc on J(l=2,m=0)
+c if imagcon .eq.10, imposed tor. field on both icb and cmb J(l=2,m=0)
+c if imagcon .eq.11, imposed tor. field on both icb and cmb J(l=2,m=0)
+c opposite sign
+c if imagcon .eq.12, imposed tor. field on both icb and cmb J(l=1,m=0)
+c if imagcon .lt. 0, imposed poloidal field via inner bc on B(l=1,m=0)
+c
+c
+c if init .eq. 0, initial conditions are read from "in".
+c if init .gt. 0, random initial entropy (and magnetic) conditions.
+c if init .lt. 0, initial hydro conditions are read from "in"
+c with random initial magnetic conditions.
+c
+c since nj .ge. (3*mmax+1)
+c and ni .ge. (3*mmax+1)/2 for triangular truncation,
+c horizontal transforms are alias free.
+c if nnaf .lt. nn, aliasing in radial transform is reduced.
+c
+c if symmetry is forced in longitude (minc .gt. 1)
+c (i.e., longitudinal periodicity of order minc)
+c then jc = 1 to nja=nj/minc.
+c
+c nstep = number of timesteps per printout (even)
+c nprnt = number of printouts per data storage
+c nstor = number of data storages per run
+c
+c---------------------------------------------------------------
+ include 'param.f'
+ include 'com3.f'
+ include 'com8.f'
+c
+ character chd*3,chg*3
+ character*72 movefile,movmfile,movafile,logfile,grafile,
+ $ lsfile,lpfile,ccfile
+c---------------------------------------------------------------
+c
+ ifirst=1
+ kc0=0
+ ispc1=1
+c open(5,file='par',form='formatted',status='old')
+c open(6,file='po',form='formatted',status='new')
+c
+ call prep
+c
+ if(nstep .lt. 1) then
+ stop '00'
+ endif
+c
+c open various output files
+c
+ logfile='l.'//outfile
+ lsfile='ls.'//outfile
+ movefile='me.'//outfile
+ movafile='ma.'//outfile
+ movmfile='mm.'//outfile
+ ccfile='cc.'//outfile
+ lpfile='lp.'//outfile
+ open(15,file=logfile,status='new',form='formatted')
+ open(16,file=lsfile,status='new',form='formatted')
+ if(nplog.gt.0)
+ $ open(17,file=lpfile,status='new',form='formatted')
+ if(mod(imovopt,10).ge.1)
+ $ open(18,file=movefile,status='new',form='formatted')
+ if(mod(imovopt,100).ge.10)
+ $ open(19,file=movafile,status='new',form='formatted')
+ if(mod(imovopt,1000).ge.100)
+ $ open(20,file=movmfile,status='new',form='formatted')
+ if(imovopt.ge.1000)
+ $ open(21,file=ccfile,status='new',form='unformatted')
+c
+c write header for movie file
+c
+ if(imovopt.lt.1) iframes=0
+ imovct=1
+ tmovnext=tmovstart
+ kvp=mod(imovopt,1000)/100
+ if(mod(imovopt,10).ge.1) call moveout(kc0)
+ if(mod(imovopt,100).ge.10) call movaout(kc0)
+ if(mod(imovopt,1000).ge.100) call movmout(kc0,kvp)
+c
+c *** start of iteration loop
+c
+ do 1 istor=1,nstor
+c
+ if(istor .gt. 1) then
+ close(14)
+ endif
+ if(nstor.gt.1) then
+ write(chd,'(''d'',i1,''.'')') istor-1
+ write(chg,'(''g'',i1,''.'')') istor-1
+ rstfile=chd//outfile
+ grafile=chg//outfile
+ else
+ rstfile='d.'//outfile
+ grafile='g.'//outfile
+ endif
+ open(10,file=rstfile,status='new',form='unformatted')
+ if(abs(ngform).eq.1)
+ $ open(14,file=grafile,status='new',form='formatted')
+ if(ngform.ge.2)
+ $ open(14,file=grafile,status='new',form='unformatted')
+c
+ do 2 iprnt=1,nprnt
+ call amhd
+ if(istop.gt.0) go to 1
+ 2 continue
+c
+ 1 continue
+c
+ if(istop.gt.0)
+ & write(6,'(/'' Terminated by stop signal'')')
+ stop 'Regular end of program mag'
+ end
Added: 3D/MAG/trunk/src/par.bnch0
===================================================================
--- 3D/MAG/trunk/src/par.bnch0 2006-06-26 21:27:17 UTC (rev 3892)
+++ 3D/MAG/trunk/src/par.bnch0 2006-06-27 00:20:45 UTC (rev 3893)
@@ -0,0 +1,39 @@
+ &contrl
+ outfile="bench0",
+ runid="Ra=1.0E5 Ek=1E-3 Els=0 Pr=1 Pm=1 RR TT H=0",
+ init=0404,
+ treset=.true.,
+ samp=0.1000,
+ nstep=200,
+ nprnt=04,
+ nstor=02,
+ nplog=0,
+ nlogstep=100,
+ ngform=1,
+ ngrad=01,
+ ngcolat=1,
+ nglon=1,
+ dtmax=1.5E-4,
+ courfac=5.0,
+ alffac=0.1,
+ radratio=0.35,
+ ra=1.0E5,
+ ek=1.00E-3,
+ pr=1.0,
+ prmag=1.0,
+ bpeak=0.0,
+ ifbfrz=.true.,
+ imagcon=0,
+ ktops=1,
+ kbots=1,
+ epsc0=-0.0,
+ ktopv=2,
+ kbotv=2,
+ difamp=0,
+ imovopt=000,
+ tmovstart=0.0,
+ tmovstep=0.E-3,
+ iframes=00,
+ icour=4 /
+ &bounds /
+
Added: 3D/MAG/trunk/src/par.bnch0_copy
===================================================================
--- 3D/MAG/trunk/src/par.bnch0_copy 2006-06-26 21:27:17 UTC (rev 3892)
+++ 3D/MAG/trunk/src/par.bnch0_copy 2006-06-27 00:20:45 UTC (rev 3893)
@@ -0,0 +1,39 @@
+ &contrl
+ outfile="bench0",
+ runid="Ra=1.0E5 Ek=1E-3 Els=0 Pr=1 Pm=1 RR TT H=0",
+ init=0404,
+ treset=.true.,
+ samp=0.1000,
+ nstep=200,
+ nprnt=04,
+ nstor=02,
+ nplog=0,
+ nlogstep=100,
+ ngform=1,
+ ngrad=01,
+ ngcolat=1,
+ nglon=1,
+ dtmax=1.5E-4,
+ courfac=5.0,
+ alffac=0.1,
+ radratio=0.35,
+ ra=1.0E5,
+ ek=1.00E-3,
+ pr=1.0,
+ prmag=1.0,
+ bpeak=0.0,
+ ifbfrz=.true.,
+ imagcon=0,
+ ktops=1,
+ kbots=1,
+ epsc0=-0.0,
+ ktopv=2,
+ kbotv=2,
+ difamp=0,
+ imovopt=000,
+ tmovstart=0.0,
+ tmovstep=0.E-3,
+ iframes=00,
+ icour=4 /
+ &bounds /
+
Added: 3D/MAG/trunk/src/par.bnch1
===================================================================
--- 3D/MAG/trunk/src/par.bnch1 2006-06-26 21:27:17 UTC (rev 3892)
+++ 3D/MAG/trunk/src/par.bnch1 2006-06-27 00:20:45 UTC (rev 3893)
@@ -0,0 +1,39 @@
+ &contrl
+ outfile="bench1",
+ runid="Ra=1.0E5 Ek=1E-3 Els=0 Pr=1 Pm=5 RR TT H=0",
+ init=0404,
+ treset=.true.,
+ samp=0.1000,
+ nstep=200,
+ nprnt=08,
+ nstor=04,
+ nplog=0,
+ nlogstep=100,
+ ngform=1,
+ ngrad=01,
+ ngcolat=1,
+ nglon=1,
+ dtmax=1.5E-4,
+ courfac=5.0,
+ alffac=0.1,
+ radratio=0.35,
+ ra=1.0E5,
+ ek=1.00E-3,
+ pr=1.0,
+ prmag=5.0,
+ bpeak=-5.0,
+ ifbfrz=.false.,
+ imagcon=0,
+ ktops=1,
+ kbots=1,
+ epsc0=-0.0,
+ ktopv=2,
+ kbotv=2,
+ difamp=0,
+ imovopt=000,
+ tmovstart=0.0,
+ tmovstep=0.E-3,
+ iframes=00,
+ icour=4 /
+ &bounds /
+
Added: 3D/MAG/trunk/src/param.f
===================================================================
--- 3D/MAG/trunk/src/param.f 2006-06-26 21:27:17 UTC (rev 3892)
+++ 3D/MAG/trunk/src/param.f 2006-06-27 00:20:45 UTC (rev 3893)
@@ -0,0 +1 @@
+link param32s4.f
\ No newline at end of file
Property changes on: 3D/MAG/trunk/src/param.f
___________________________________________________________________
Name: svn:special
+ *
Added: 3D/MAG/trunk/src/param32s1.f
===================================================================
--- 3D/MAG/trunk/src/param32s1.f 2006-06-26 21:27:17 UTC (rev 3892)
+++ 3D/MAG/trunk/src/param32s1.f 2006-06-27 00:20:45 UTC (rev 3893)
@@ -0,0 +1,13 @@
+ parameter (nn=25,ni=48,nj=096,nnaf=23,minc=1)
+c
+c This file is an example of a input grid parameter file
+c to be linked to 'param.f' using command 'ln -sf param32s6.f param.f'
+c after linking, run the makefile with command 'make'.
+c
+ parameter (nnp2=nn+2,nnp1=nn+1,nn1=nn-1,nn2=nn-2,nn3=nn-3,
+ $nps2=nnp1/2,ns2=nn1/2,nnx2=2*nn,nja=nj/minc,
+ $nrp=nja+2,ncp=nrp/2,ntf=3*nja/2+1,njp1=nj+1,nip1=ni+1,
+ $lmax=(nj)/3,mmax=(lmax/minc)*minc,nmaf=mmax+1,
+ $nmafa=mmax/minc+1,nlm=(nmaf*(nmaf+1))/2,nlaf=lmax+1,
+ $nlma=mmax*nlaf/minc-mmax*(mmax-minc)/(2*minc)+nlaf-mmax,
+ $lot=2*nlma,nlafp1=nlaf+1,nlmpa=nlma+nmafa)
Added: 3D/MAG/trunk/src/param32s4.f
===================================================================
--- 3D/MAG/trunk/src/param32s4.f 2006-06-26 21:27:17 UTC (rev 3892)
+++ 3D/MAG/trunk/src/param32s4.f 2006-06-27 00:20:45 UTC (rev 3893)
@@ -0,0 +1,13 @@
+ parameter (nn=25,ni=48,nj=096,nnaf=23,minc=4)
+c
+c This file is an example of a input grid parameter file
+c to be linked to 'param.f' using command 'ln -sf param32s6.f param.f'
+c after linking, run the makefile with command 'make'.
+c
+ parameter (nnp2=nn+2,nnp1=nn+1,nn1=nn-1,nn2=nn-2,nn3=nn-3,
+ $nps2=nnp1/2,ns2=nn1/2,nnx2=2*nn,nja=nj/minc,
+ $nrp=nja+2,ncp=nrp/2,ntf=3*nja/2+1,njp1=nj+1,nip1=ni+1,
+ $lmax=(nj)/3,mmax=(lmax/minc)*minc,nmaf=mmax+1,
+ $nmafa=mmax/minc+1,nlm=(nmaf*(nmaf+1))/2,nlaf=lmax+1,
+ $nlma=mmax*nlaf/minc-mmax*(mmax-minc)/(2*minc)+nlaf-mmax,
+ $lot=2*nlma,nlafp1=nlaf+1,nlmpa=nlma+nmafa)
Added: 3D/MAG/trunk/src/param32s6.f
===================================================================
--- 3D/MAG/trunk/src/param32s6.f 2006-06-26 21:27:17 UTC (rev 3892)
+++ 3D/MAG/trunk/src/param32s6.f 2006-06-27 00:20:45 UTC (rev 3893)
@@ -0,0 +1,13 @@
+ parameter (nn=25,ni=48,nj=096,nnaf=23,minc=6)
+c
+c This file is an example of a input grid parameter file
+c to be linked to 'param.f' using command 'ln -sf param32s6.f param.f'
+c after linking, run the makefile with command 'make'.
+c
+ parameter (nnp2=nn+2,nnp1=nn+1,nn1=nn-1,nn2=nn-2,nn3=nn-3,
+ $nps2=nnp1/2,ns2=nn1/2,nnx2=2*nn,nja=nj/minc,
+ $nrp=nja+2,ncp=nrp/2,ntf=3*nja/2+1,njp1=nj+1,nip1=ni+1,
+ $lmax=(nj)/3,mmax=(lmax/minc)*minc,nmaf=mmax+1,
+ $nmafa=mmax/minc+1,nlm=(nmaf*(nmaf+1))/2,nlaf=lmax+1,
+ $nlma=mmax*nlaf/minc-mmax*(mmax-minc)/(2*minc)+nlaf-mmax,
+ $lot=2*nlma,nlafp1=nlaf+1,nlmpa=nlma+nmafa)
Added: 3D/MAG/trunk/src/param96s6.f
===================================================================
--- 3D/MAG/trunk/src/param96s6.f 2006-06-26 21:27:17 UTC (rev 3892)
+++ 3D/MAG/trunk/src/param96s6.f 2006-06-27 00:20:45 UTC (rev 3893)
@@ -0,0 +1,13 @@
+ parameter (nn=25,ni=144,nj=288,nnaf=23,minc=6)
+c
+c This file is an example of a input grid parameter file
+c to be linked to 'param.f' using command 'ln -sf param32s6.f param.f'
+c after linking, run the makefile with command 'make'.
+c
+ parameter (nnp2=nn+2,nnp1=nn+1,nn1=nn-1,nn2=nn-2,nn3=nn-3,
+ $nps2=nnp1/2,ns2=nn1/2,nnx2=2*nn,nja=nj/minc,
+ $nrp=nja+2,ncp=nrp/2,ntf=3*nja/2+1,njp1=nj+1,nip1=ni+1,
+ $lmax=(nj)/3,mmax=(lmax/minc)*minc,nmaf=mmax+1,
+ $nmafa=mmax/minc+1,nlm=(nmaf*(nmaf+1))/2,nlaf=lmax+1,
+ $nlma=mmax*nlaf/minc-mmax*(mmax-minc)/(2*minc)+nlaf-mmax,
+ $lot=2*nlma,nlafp1=nlaf+1,nlmpa=nlma+nmafa)
Added: 3D/MAG/trunk/src/pbar.f
===================================================================
--- 3D/MAG/trunk/src/pbar.f 2006-06-26 21:27:17 UTC (rev 3892)
+++ 3D/MAG/trunk/src/pbar.f 2006-06-27 00:20:45 UTC (rev 3893)
@@ -0,0 +1,30 @@
+ subroutine pbar(the,l,m,p)
+c
+c pbar calculates the value of the normalized associated
+c legendre function of the first kind, of degree l,
+c of order m, for the real argument cos(the), and returns
+c it in the variable p
+c 0 .le. m .le. l
+c
+c called in gquad and prep
+c
+ s=sin(the)
+ c=cos(the)
+ p=1./sqrt(2.)
+ if(m .eq. 0) go to 22
+ do 20 i=1,m
+ p=sqrt(float(2*i+1)/float(2*i))*s*p
+ 20 continue
+ 22 continue
+ if(l .eq. m) return
+ p1=1.
+ m1=m+1
+ do 30 j=m1,l
+ p2=p1
+ p1=p
+ p=2.*sqrt((float(j**2)-0.25)/float(j**2-m**2))*c*p1-
+ $sqrt(float((2*j+1)*(j-m-1)*(j+m-1))/
+ $float((2*j-3)*(j-m)*(j+m)))*p2
+ 30 continue
+ return
+ end
Added: 3D/MAG/trunk/src/prep.f
===================================================================
--- 3D/MAG/trunk/src/prep.f 2006-06-26 21:27:17 UTC (rev 3892)
+++ 3D/MAG/trunk/src/prep.f 2006-06-27 00:20:45 UTC (rev 3893)
@@ -0,0 +1,1005 @@
+ subroutine prep
+c
+c nj must be multiple of 4
+c ni should be nj/2
+c nn must be of form 4*i+1, where i is an integer
+c
+c---------------------------------------------------------------
+ include 'param.f'
+ include 'com1.f'
+ include 'com2.f'
+ include 'com3.f'
+ include 'com4.f'
+ include 'com5.f'
+ include 'com6.f'
+ include 'com7.f'
+ include 'com8.f'
+c
+ dimension colat(ni),clm(nlafp1,nmafa),gauss(ni),
+ $bleg1(nlafp1),bleg2(nlafp1),bleg3(nlaf),
+ $rv1(nnp2),rv2(nnp2),rv3(nnp2)
+c
+ character*72 infile
+c
+ logical treset
+c
+ namelist /contrl/ outfile,infile,runid,
+ $init,nstep,nprnt,nstor,iframes,tmovstart,tmovstep,imovopt,
+ $alpha,courfac,alffac,tipdipole,ra,pr,prmag,ek,radratio,cmb,
+ $epsc0,dtmax,dtstart,bpeak,difamp,ldif,ldifexp,
+ $icour,samp,nlogstep,treset,iscale,enscale,
+ $amps,ampb,ampj,ampw,ampz,imagcon,
+ $ktops,kbots,ktopv,kbotv,ktopb,kbotb,ifvfrz,ifbfrz,ifsfrz,
+ $ngform,ngcolat,ngrad,nglon,nplog,nfilt,alfilt,ivfilt,dipfilt
+c
+ namelist /bounds/ tops,bots
+c
+ runid="Dummy run name for magb"
+ outfile="dummy"
+ infile="in"
+ init=0
+ alpha=0.6
+ courfac=2.5
+ alffac=1.0
+ dtmax=1.e-3
+ radratio=0.35
+ ra=1.e5
+ ek=1.e-3
+ pr=1.
+ prmag=1.
+ epsc0=0.0
+ cmb=0.0
+ bpeak=0.
+ difamp=0.
+ ldif=1
+ ldifexp=-1
+ icour=2
+ samp=1.
+ amps=1.
+ ampb=1.
+ ampj=1.
+ ampw=1.
+ ampz=1.
+ imagcon=0
+ ktops=1
+ kbots=1
+ ktopv=2
+ kbotv=2
+ ktopb=1
+ kbotb=1
+ ifvfrz=.false.
+ ifbfrz=.false.
+ ifsfrz=.false.
+ ngform=0
+ ngrad=1
+ ngcolat=1
+ nglon=1
+ imovopt=0
+ iframes=0
+ tmovstart=0.
+ tmovstep=0.5e-3
+ treset=.false.
+ nlogstep=25
+ nplog=0
+ nfilt=0
+ alfilt=9999.
+ ivfilt=-1
+ dipfilt=1.0
+ iscale=1
+ enscale=1.
+ dtstart=0.0
+ tipdipole=0.0
+c
+ i01=1
+c---------------------------------------------------------------
+c
+ write(6,*) 'magb'
+c
+ if(minc.lt.1) stop '04'
+ if((minc.eq.1) .and. (nlma.ne.nlm)) stop '05'
+ if(mod(nj,minc) .ne. 0) stop '06'
+ if(mod(nja,2) .ne. 0) stop '07'
+ njd2=nja/2
+ if((mod(njd2,2) .ne. 0) .or. (njd2 .le. 2)) stop '08'
+ if((mod(nn1,4) .ne. 0) .or. (nn .le. 3)) stop '09'
+ if(ni .le. 2) stop '09'
+ if(ni .lt. nj/2) stop '10'
+ if((nnaf .gt. nn) .or. (nnaf .lt. 1)) stop '11'
+c note if (nja+1)*ni .gt. lot*nnp2, then dimension work(lot,nwk)
+c where nwk=(nja+1)*ni/lot+1
+c since work is used by both fourtf and chebtf
+ if((nja+1)*ni .gt. lot*nnp2) stop '12'
+c
+ write(6,267)
+ 267 format(/,2x,"triangular truncation of spherical harmonics")
+ nmax=nnaf-1
+ write(6,266) nn,ni,nj,nmax,lmax,mmax
+ 266 format(/,2x," nn =",i4," ni =",i4," nj =",i4,
+ $ 2x,"nmax =",i4," lmax =",i4," mmax =",i4,/)
+ if(minc.gt.1) write(6,268) minc
+ 268 format(2x,i3," - fold symmetry in longitude",/)
+c
+c *** control parameters
+c
+ do m=0,mmax
+ do l=0,lmax
+ tops(l,m)=0.
+ bots(l,m)=0.
+ enddo
+ enddo
+c
+ read(5,contrl)
+ read(5,bounds)
+c
+ opr=1./pr
+ opm=1./prmag
+ oek=1./ek
+ oekpm=oek*opm
+ rapr=ra/pr
+ dtmax=min(dtmax,0.25*ek)
+ dtmin=dtmax/10000.
+c
+ do l=0,lmax
+ tops(l,0)=real(tops(l,0))
+ bots(l,0)=real(bots(l,0))
+ enddo
+c **************************************************
+c for this magneto-convection version:
+c the bpeak bc on aj(3,..), aj(2,..) or b(2,nn) requires
+ kbotb=1
+c **************************************************
+ ldif=max(1,ldif)
+ ldif=min(lmax,ldif)
+ if(mod(icour,2) .ne. 0) icour=icour+1
+ write(6,contrl)
+ if(mod(nstep,2) .eq. 0) nstep=nstep-1
+ do m=0,mmax
+ do l=m,lmax
+ if(tops(l,m) .ne. cmplx(0.,0.))
+ $ write(6,901) m,l,tops(l,m)
+ 901 format(" m =",i3," l =",i3,
+ $ " tops =",2(1x,1pe12.5))
+ if(bots(l,m) .ne. cmplx(0.,0.))
+ $ write(6,902) m,l,bots(l,m)
+ 902 format(" m =",i3," l =",i3,
+ $ " bots =",2(1x,1pe12.5))
+ enddo
+ enddo
+c
+c *** parameters
+c
+ ai=cmplx(0.,1.)
+ pi=4.*atan(1.)
+ pik=pi/float(nn1)
+ sqrt2pi=sqrt(2.*pi)
+ y00=1./sqrt(4.*pi)
+ p00co=4./sqrt(3.)
+ anorm=sqrt(2./float(nn1))
+c
+c radial grid structure
+c
+ radtop=1./(1.-radratio)
+ radbot=radtop-1.
+ ocorevol =4.*pi/3. *(radtop**3 - radbot**3)
+c
+ do kc=1,nn
+ r(kc)=radbot+0.5*(1.+cos(float(kc-1)*pik))
+ enddo
+c
+c *** input data
+c
+c -----------------------------------------------------------------
+ if(init .le. 0) then ! initial condition from restart file
+c -----------------------------------------------------------------
+ open(8,file=infile,status='old',form='unformatted')
+ read(8) time,dt,raold,prold,pmold,ekold,radratiold,
+ $ kstep,nnold,niold,njold,minco
+ write(6,260) infile
+ 260 format(/,2x,"input file: ",a64,/)
+c
+ if(ra.ne.raold.or.pr.ne.prold.or.prmag.ne.pmold.or.
+ $ ek.ne.ekold.or.radratio.ne.radratiold) then
+ write(6,262)
+ 262 format("Parameter values changed New / Old : ")
+ write(6,263) radratio,ra,pr,prmag,ek
+ write(6,263) radratiold,raold,prold,pmold,ekold
+ 263 format('radratio= ',f8.5,' ra= ',f9.0,' pr= ',f7.3,
+ $ ' prmag= ',f7.3,' ek= ',e12.4)
+ endif
+c
+ if(dtstart.gt.0.0) dt=dtstart
+ if(ni.eq.niold.and.nj.eq.njold.and.minc.eq.minco
+ $ .and.nn.eq.nnold) then
+ read(8) w,z,p,s
+ read(8) dsdt1,dwdt1,dzdt1,dpdt1
+ if(init .gt. -10) read(8) b,aj,dbdt1,djdt1
+ else
+c
+c mapping from different grid
+c
+ccc
+ write(6,'(4i4)') nnold,niold,njold,minco
+ call mapdata(nnold,niold,njold,minco)
+ endif
+c
+ if(init.lt.-6.and.ifvfrz) call zerorot(init)
+c
+ if(treset) then
+ time=0.
+ kstep=0
+ endif
+c -----------------------------------------------------------------
+ else ! initial condition from scratch
+c -----------------------------------------------------------------
+ kstep=0
+ time=0.
+ if(dtstart.gt.0.0) then
+ dt=dtstart
+ else
+ dt=dtmax
+ endif
+c -----------------------------------------------------------------
+ endif
+c -----------------------------------------------------------------
+c
+ dtold=dt
+ oodt=1./dt
+c
+c *** chebyshev polynomials and derivatives
+c
+ do 10 kc=1,nn
+ do 10 nc=1,nn
+ cheb(nc,kc)=cos(float((nc-1)*(kc-1))*pik)
+ 10 continue
+c
+ do 70 kc=1,nn
+ dcheb(1,kc)=0.
+ do 71 nc=2,nn
+ if(mod(nc,2) .eq. 0) go to 72
+ dcheb(nc,kc)=0.
+ n1=2
+ go to 73
+ 72 dcheb(nc,kc)=0.5
+ n1=3
+ 73 n2=nc-1
+ if(n2 .lt. n1) go to 69
+ do 74 ncc=n1,n2,2
+ dcheb(nc,kc)=dcheb(nc,kc)+cheb(ncc,kc)
+ 74 continue
+ 69 dcheb(nc,kc)=float(2*(nc-1))*dcheb(nc,kc)
+ 71 continue
+ d2cheb(1,kc)=0.
+ d2cheb(2,kc)=0.
+ do 75 nc=3,nn
+ if(mod(nc,2) .eq. 0) go to 76
+ d2cheb(nc,kc)=0.5*float((nc-1)**2)
+ n1=3
+ go to 77
+ 76 d2cheb(nc,kc)=0.
+ n1=2
+ 77 n2=nc-2
+ if(n2 .lt. n1) go to 79
+ do 78 ncc=n1,n2,2
+ d2cheb(nc,kc)=d2cheb(nc,kc)+float((nc-ncc)*(nc+ncc-2))
+ $*cheb(ncc,kc)
+ 78 continue
+ 79 d2cheb(nc,kc)=float(nc-1)*d2cheb(nc,kc)
+ 75 continue
+ 70 continue
+ do 90 ncc=1,nn
+ do 91 kc=1,nn
+ rv1(kc)=d2cheb(ncc,kc)
+ 91 continue
+ call rderiv(1.,anorm,rv1,rv2)
+ do 92 kc=1,nn
+ d3cheb(ncc,kc)=0.5*rv2(kc)
+ 92 continue
+ 90 continue
+ do 94 kc=1,nn
+ d3cheb(1,kc)=0.
+ d3cheb(2,kc)=0.
+ d3cheb(3,kc)=0.
+ 94 continue
+c
+ call chebi(nn,wsave,trigsc,ifaxc,k2k)
+c
+c *** complex fourier polynomials
+c
+ call fax(ifaxf,nja,3)
+ k=ifaxf(1)
+ if((k .lt. 1) .or. (ifaxf(k+1) .gt. 5)) stop '17'
+ctest
+ write(6,'(/'' Fourier factors= '',10I2/)')
+ $ (ifaxf(kk),kk=2,k+1)
+ call fftrig(trigsf,nja,3)
+c
+c *** radially dependent variables
+c
+ do kc=1,nn
+ grav(kc)=r(kc)/radtop
+ qk(kc,1)=1./r(kc)**2
+ qk(kc,2)=4./r(kc)
+ qk(kc,3)=1./r(kc)
+ qk(kc,4)=1./r(kc)**4
+ qk(kc,5)=2./r(kc)**3
+ qk(kc,6)=2./r(kc)
+ enddo
+c
+c *** scaling parameters
+c
+ zscl=dt*radtop**2
+ wscl=zscl
+ pscl=radtop**2
+ sscl=dt
+ oosscl=1./sscl
+ bscl=dt*radtop**2
+ ampnu=2.*oek*radtop*radtop/real(lmax*(lmax+1))
+ ampnu=max(1.d0,ampnu)
+c
+ lm0=3
+ if(imagcon .gt. 0) then
+ if(imagcon.eq.12) lm0=2
+ b0norm=4./float(lm0) * sqrt(pi/(2.*float(lm0)-1.))
+ bpeakbot=b0norm*radbot/bscl*bpeak
+ if(imagcon.ge.10) then
+ bpeaktop=b0norm*radtop/bscl*bpeak
+ if(imagcon.eq.11) bpeaktop=-bpeaktop
+ else
+ bpeaktop=.0
+ endif
+ else if(imagcon.lt.0) then
+ bpeakbot=-sqrt(pi/3.)*radbot*radbot/bscl*bpeak
+ bpeaktop=.0
+ else
+ bpeaktop=.0
+ bpeakbot=.0
+ endif
+c
+ if((ktops.eq.1) .and. (kbots.eq.1)) then
+ tops(0,0)=-radbot*radbot/(radtop*radtop+radbot*radbot)/y00
+ bots(0,0)= radtop*radtop/(radtop*radtop+radbot*radbot)/y00
+ endif
+c
+ do l=0,lmax
+ do m=0,min(l,mmax)
+ tops(l,m)=tops(l,m)*oosscl
+ bots(l,m)=bots(l,m)*oosscl
+ enddo
+ enddo
+c
+c *** courant lengths
+c
+ c1=1./float(lmax*(lmax+1))
+ delxh2(1)=c1*r(1)**2
+ delxh2(nn)=c1*r(nn)**2
+ delxr(1)=r(1)-r(2)
+ delxr(nn)=r(nn1)-r(nn)
+ do 120 kc=2,nn1
+ delxh2(kc)=c1*r(kc)**2
+ delxr(kc)=min((r(kc-1)-r(kc)),(r(kc)-r(kc+1)))
+ 120 continue
+c
+c *** chebyshev integrals
+c
+ c1=0.0625
+ c2=0.5*(r(nn)+0.5)
+ c3=(r(nn)+0.5)**2+0.125
+ do 18 nc=1,nnp2
+ rv1(nc)=0.
+ 18 continue
+ do 19 nc=1,nnp2,2
+ n=nc-1
+ rv1(nc)=2./(1.-float(n**2))
+ 19 continue
+ do 20 nc=1,nn
+ n=nc-1
+ qn(nc,1)=(c1*rv1(iabs(n-2)+1)+c2*rv1(iabs(n-1)+1)+
+ $c3*rv1(nc)+c2*rv1(nc+1)+c1*rv1(nc+2))
+ qn(nc,3)=0.
+ qn(nc,4)=0.
+ 20 continue
+ do 28 nc=1,nn,2
+ qn(nc,3)=2./(1.-float((nc-1)**2))
+ 28 continue
+c
+ do 22 ncc=1,nn
+ do 23 kc=1,nn
+ rv1(kc)=0.0
+ rv3(kc)=cheb(ncc,kc)*r(kc)**2
+ 23 continue
+ call chebtf(i01,ns2,i01,nn1,ns2,rv1,rv1,rv1,wsave,
+ $work,work(2,1),work(2,1),work(2,1),trigsc,ifaxc,k2k)
+ call chebtf(i01,ns2,i01,nn1,ns2,rv3,rv3,rv3,wsave,
+ $work,work(2,1),work(2,1),work(2,1),trigsc,ifaxc,k2k)
+ do 26 nc=2,nn3,2
+ rv2(nc)=(rv1(nc-1)-rv1(nc+1))/float(2*(nc-1))
+ rva(nc)=(rv3(nc-1)-rv3(nc+1))/float(2*(nc-1))
+ 26 continue
+ qn(ncc,2)=rv1(nn)/float(4*nn)
+ qn(ncc,5)=rv3(nn)/float(4*nn)
+ qn(ncc,6)=0.0
+ rv2(nn1)=(rv1(nn2)-0.5*rv1(nn))/float(2*nn2)
+ rva(nn1)=(rv3(nn2)-0.5*rv3(nn))/float(2*nn2)
+ do 27 ncb=1,nn2,2
+ nc=nn-ncb
+ qn(ncc,2)=qn(ncc,2)+rv2(nc)
+ qn(ncc,5)=qn(ncc,5)+rva(nc)
+ 27 continue
+ qn(ncc,2)=2.*anorm*qn(ncc,2)
+ qn(ncc,5)=2.*anorm*qn(ncc,5)
+ 22 continue
+c
+c *** horizontally dependent coefficients
+c
+ call gquad(ni,colat,gauss)
+c
+ do 32 ic=1,ni
+ qi(ic,1)=1./(sin(colat(ic)))**2
+ qi(ic,2)=cos(colat(ic))*qi(ic,1)
+ qi(ic,3)=sin(colat(ic))
+ qi(ic,4)=cos(colat(ic))
+ qi(ic,5)= colat(ic)
+ 32 continue
+c
+c
+ do 33 mc=1,nmaf,minc
+ m=mc-1
+ mca=m/minc+1
+ do 34 lc=mc,nlafp1
+ l=lc-1
+ clm(lc,mca)=sqrt(float((l+m)*(l-m))/float((2*l-1)*(2*l+1)))
+ 34 continue
+ 33 continue
+c
+ lm=0
+ lmp=0
+ do 35 mc=1,nmaf,minc
+ m=mc-1
+ mca=m/minc+1
+ do 31 lc=mc,nlaf
+ l=lc-1
+ lm=lm+1
+ lmp=lmp+1
+ mclm(lm)=mc
+ mclma(lm)=mca
+ mcalmp(lmp)=mca
+ ql(lm,1)=float(l+2)*clm(lc+1,mca)
+ if(lc .eq. nlaf) ql(lm,1)=0.
+ ql(lm,2)=float(l-1)*clm(lc,mca)
+ ql(lm,3)=float(l*lc)
+ ql(lm,4)=float(l)
+ ql(lm,5)=float(lc)
+ ql(lm,6)=ql(lm,3)
+ if(mc .eq. 1) ql(lm,6)=0.5*ql(lm,6)
+ ql(lm,7)=float(lc)*clm(lc,mca)
+ ql(lm,8)=float(l)*clm(lc+1,mca)
+c note: if(lc .eq. nlaf) ql(lm,8) .ne. 0, use only for nl terms
+ ql(lm,9)=1.
+ if(l .eq. lmax) ql(lm,9)=0.
+ ql(lm,10)=float(m)
+ if((ldifexp .gt. 0) .and. (l .ge. ldif)) then
+ ql(lm,11)=ql(lm,3)*(1.+
+ $ difamp*(float(l+1-ldif)/float(lmax+1-ldif))**ldifexp)
+ ql(lm,12)=ql(lm,3)*(1.+
+ $ difamp*(float(l+1-ldif)/float(lmax+1-ldif))**ldifexp)
+ else
+ ql(lm,11)=ql(lm,3)
+ ql(lm,12)=ql(lm,3)
+ endif
+ if(l .eq. lmax) ql(lm,12)=ampnu*ql(lm,12)
+ ql(lm,13)=ql(lm,10)*ql(lm,9)
+ ql(lm,14)=ql(lm,1)*ql(lm,9)
+ ql(lm,15)=ql(lm,2)*ql(lm,9)
+ ql(lm,16)=ql(lm,4)*ql(lm,1)*ql(lm,9)
+ ql(lm,17)=ql(lm,5)*ql(lm,9)
+ ql(lm,18)=ql(lm,5)*ql(lm,2)*ql(lm,9)
+ ql(lm,19)=ql(lm,4)*ql(lm,9)
+ ql(lm,20)=ql(lm,3)*ql(lm,9)
+ 31 continue
+ lmp=lmp+1
+ mcalmp(lmp)=mca
+ 35 continue
+ if(lm .ne. nlma) then
+ write(6,*) lm,' .ne. nlma .eq. ',nlma
+ stop '18'
+ endif
+ if(lmp .ne. nlmpa) then
+ write(6,*) lmp,' .ne. nlmpa .eq. ',nlmpa
+ stop '19'
+ endif
+c
+c *** legendre functions
+c
+ do 36 ic=1,ni
+ lm=0
+ lmp=0
+ do 36 mc=1,nmaf,minc
+ m=mc-1
+ mca=m/minc+1
+ xm=(-1.)**m
+ do 37 lc=mc,nlafp1
+ l=lc-1
+ call pbar(colat(ic),l,m,plm)
+ bleg1(lc)=xm/sqrt2pi*plm
+ bleg2(lc)=xm*sqrt2pi*gauss(ic)*plm
+ 37 continue
+ bleg3(mc)=float(m)*clm(mc+1,mca)*bleg1(mc+1)
+ if(mc .lt. nmaf) then
+ do 39 lc=mc+1,nlaf
+ l=lc-1
+ bleg3(lc)=float(l)*clm(lc+1,mca)*bleg1(lc+1)-
+ $ float(lc)*clm(lc,mca)*bleg1(lc-1)
+ 39 continue
+ endif
+ do 52 lc=mc,nlaf
+ lm=lm+1
+ lmp=lmp+1
+ aleg1(lm,ic)=bleg1(lc)
+ aleg2(lmp,ic)=bleg2(lc)
+ aleg3(lm,ic)=bleg3(lc)
+ 52 continue
+ lmp=lmp+1
+ aleg2(lmp,ic)=bleg2(nlaf+1)
+ 36 continue
+c
+c *** initial conditions
+c
+ do 644 kc=1,nnp1
+ w(1,kc)=0.
+ dw(1,kc)=0.
+ ddw(1,kc)=0.
+ z(1,kc)=0.
+ dz(1,kc)=0.
+ b(1,kc)=0.
+ db(1,kc)=0.
+ ddb(1,kc)=0.
+ aj(1,kc)=0.
+ dj(1,kc)=0.
+ 644 continue
+ do 645 kc=1,nn
+ dpdt(1,kc,1)=0.
+ dpdt(1,kc,2)=0.
+ dzdt(1,kc,1)=0.
+ dzdt(1,kc,2)=0.
+ dbdt(1,kc,1)=0.
+ dbdt(1,kc,2)=0.
+ djdt(1,kc,1)=0.
+ djdt(1,kc,2)=0.
+ 645 continue
+c
+c -radial derivatives
+c
+ if(init .le. 0) then
+ if(amps .ne. 1.) then
+ do kc=1,nn
+ do lm=1,nlma
+ s(lm,kc)=amps*s(lm,kc)
+ dsdt(lm,kc,1)=amps*dsdt(lm,kc,1)
+ enddo
+ enddo
+ endif
+ if((ampw .ne. 1.) .or. (ampz .ne. 1.)) then
+ do kc=1,nn
+ do lm=1,nlma
+ w(lm,kc)=ampw*w(lm,kc)
+ dwdt(lm,kc,1)=ampw*dwdt(lm,kc,1)
+ z(lm,kc)=ampz*z(lm,kc)
+ dzdt(lm,kc,1)=ampz*dzdt(lm,kc,1)
+ enddo
+ enddo
+ endif
+ call chebtf(lot,ns2,lot,nnp1,nps2,
+ $ w,w,w,wsave,work,
+ $ work(1,2),work(1,2),work(1,2),trigsc,ifaxc,k2k)
+ call chebtf(lot,ns2,lot,nnp1,nps2,
+ $ z,z,z,wsave,work,
+ $ work(1,2),work(1,2),work(1,2),trigsc,ifaxc,k2k)
+ do lm=1,nlma
+ dw(lm,nn)=0.
+ dw(lm,nn1)=float(nn1)*w(lm,nn)
+ ddw(lm,nn)=0.
+ ddw(lm,nn1)=0.
+ dz(lm,nn)=0.
+ dz(lm,nn1)=float(nn1)*z(lm,nn)
+ enddo
+ do n=nn2,1,-1
+ do lm=1,nlma
+ dw(lm,n)=dw(lm,n+2)+float(2*n)*w(lm,n+1)
+ ddw(lm,n)=ddw(lm,n+2)+float(2*n)*dw(lm,n+1)
+ dz(lm,n)=dz(lm,n+2)+float(2*n)*z(lm,n+1)
+ enddo
+ enddo
+ call chebtf(lot,ns2,lot,nnp1,nps2,
+ $ w,w,w,wsave,work,
+ $ work(1,2),work(1,2),work(1,2),trigsc,ifaxc,k2k)
+ call chebtf(lot,ns2,lot,nnp1,nps2,
+ $ dw,dw,dw,wsave,work,
+ $ work(1,2),work(1,2),work(1,2),trigsc,ifaxc,k2k)
+ call chebtf(lot,ns2,lot,nnp1,nps2,
+ $ ddw,ddw,ddw,wsave,work,
+ $ work(1,2),work(1,2),work(1,2),trigsc,ifaxc,k2k)
+ call chebtf(lot,ns2,lot,nnp1,nps2,
+ $ z,z,z,wsave,work,
+ $ work(1,2),work(1,2),work(1,2),trigsc,ifaxc,k2k)
+ call chebtf(lot,ns2,lot,nnp1,nps2,
+ $ dz,dz,dz,wsave,work,
+ $ work(1,2),work(1,2),work(1,2),trigsc,ifaxc,k2k)
+ do kc=1,nnp1
+ w(1,kc)=0.
+ dw(1,kc)=0.
+ ddw(1,kc)=0.
+ z(1,kc)=0.
+ dz(1,kc)=0.
+ enddo
+ endif
+c
+ if(init .gt. -10) then
+ if((ampb .ne. 1.) .or. (ampj .ne. 1.)) then
+ do kc=1,nn
+ do lm=1,nlma
+ b(lm,kc)=ampb*b(lm,kc)
+ dbdt(lm,kc,1)=ampb*dbdt(lm,kc,1)
+ aj(lm,kc)=ampj*aj(lm,kc)
+ djdt(lm,kc,1)=ampj*djdt(lm,kc,1)
+ enddo
+ enddo
+ endif
+ call chebtf(lot,ns2,lot,nnp1,nps2,
+ $ b,b,b,wsave,work,
+ $ work(1,2),work(1,2),work(1,2),trigsc,ifaxc,k2k)
+ call chebtf(lot,ns2,lot,nnp1,nps2,
+ $ aj,aj,aj,wsave,work,
+ $ work(1,2),work(1,2),work(1,2),trigsc,ifaxc,k2k)
+ do lm=1,nlma
+ db(lm,nn)=0.
+ db(lm,nn1)=float(nn1)*b(lm,nn)
+ ddb(lm,nn)=0.
+ ddb(lm,nn1)=0.
+ dj(lm,nn)=0.
+ dj(lm,nn1)=float(nn1)*aj(lm,nn)
+ enddo
+ do n=nn2,1,-1
+ do lm=1,nlma
+ db(lm,n)=db(lm,n+2)+float(2*n)*b(lm,n+1)
+ ddb(lm,n)=ddb(lm,n+2)+float(2*n)*db(lm,n+1)
+ dj(lm,n)=dj(lm,n+2)+float(2*n)*aj(lm,n+1)
+ enddo
+ enddo
+ call chebtf(lot,ns2,lot,nnp1,nps2,
+ $ b,b,b,wsave,work,
+ $ work(1,2),work(1,2),work(1,2),trigsc,ifaxc,k2k)
+ call chebtf(lot,ns2,lot,nnp1,nps2,
+ $ db,db,db,wsave,work,
+ $ work(1,2),work(1,2),work(1,2),trigsc,ifaxc,k2k)
+ call chebtf(lot,ns2,lot,nnp1,nps2,
+ $ ddb,ddb,ddb,wsave,work,
+ $ work(1,2),work(1,2),work(1,2),trigsc,ifaxc,k2k)
+ call chebtf(lot,ns2,lot,nnp1,nps2,
+ $ aj,aj,aj,wsave,work,
+ $ work(1,2),work(1,2),work(1,2),trigsc,ifaxc,k2k)
+ call chebtf(lot,ns2,lot,nnp1,nps2,
+ $ dj,dj,dj,wsave,work,
+ $ work(1,2),work(1,2),work(1,2),trigsc,ifaxc,k2k)
+ do kc=1,nnp1
+ b(1,kc)=0.
+ db(1,kc)=0.
+ ddb(1,kc)=0.
+ aj(1,kc)=0.
+ dj(1,kc)=0.
+ enddo
+ endif
+c
+c -initial entropy field and boundary conditions
+c
+ do 40 nc=1,nn
+ do 40 kc=1,nn
+ s0mat(kc,nc)=sscl*anorm*opr*
+ $ (4.*d2cheb(nc,kc)+qk(kc,2)*dcheb(nc,kc))
+ 40 continue
+ do 41 nc=1,nnaf
+ if(ktops .eq. 1) then
+ s0mat(1,nc)=anorm
+ else
+ s0mat(1,nc)=2.*dcheb(nc,1)*anorm
+ endif
+ if(kbots .eq. 1) then
+ s0mat(nn,nc)=cheb(nc,nn)*anorm
+ else
+ s0mat(nn,nc)=2.*dcheb(nc,nn)*anorm
+ endif
+ 41 continue
+ if(nnaf .lt. nn) then
+ do 911 nc=nnaf+1,nn
+ s0mat(1,nc)=0.
+ s0mat(nn,nc)=0.
+ 911 continue
+ endif
+ do 42 kc=1,nn
+ s0mat(kc,1)=0.5*s0mat(kc,1)
+ s0mat(kc,nn)=0.5*s0mat(kc,nn)
+ 42 continue
+ call sgefa(s0mat,nn,nn,is0,info)
+ if(info .ne. 0) stop '20'
+ do 44 kc=2,nn1
+ rva(kc)=-epsc0
+ 44 continue
+ rva(1)=real(tops(0,0))
+ rva(nn)=real(bots(0,0))
+ call sgesl(s0mat,nn,nn,is0,rva,0)
+ do nc=1,nnaf
+ rva(nc)=rva(nc)*sscl
+ enddo
+ if(nnaf .lt. nn) then
+ do 912 nc=nnaf+1,nn
+ rva(nc)=0.
+ 912 continue
+ endif
+ call chebtf(1,ns2,1,nn1,ns2,rva,rva,rva,wsave,
+ $work,work(2,1),work(2,1),work(2,1),trigsc,ifaxc,k2k)
+c
+ do 58 lm=1,nlma
+ s(lm,nnp1)=0.
+ w(lm,nnp1)=0.
+ z(lm,nnp1)=0.
+ p(lm,nnp1)=0.
+ dw(lm,nnp1)=0.
+ ddw(lm,nnp1)=0.
+ dz(lm,nnp1)=0.
+ b(lm,nnp1)=0.
+ aj(lm,nnp1)=0.
+ db(lm,nnp1)=0.
+ ddb(lm,nnp1)=0.
+ dj(lm,nnp1)=0.
+ 58 continue
+c
+ if(init .gt. 0 .or. init .le. -10) then
+c
+c -initial toroidal magnetic field
+c
+ if(imagcon .ge. 0) then
+ do nc=1,nn
+ do kc=1,nn
+ s0mat(kc,nc)=ql(lm0,3)*opm*qk(kc,1)*
+ $ (4.*d2cheb(nc,kc)-
+ $ ql(lm0,3)*qk(kc,1)*cheb(nc,kc))*anorm*bscl
+ enddo
+ enddo
+ do nc=1,nnaf
+ s0mat(1,nc)=anorm
+ s0mat(nn,nc)=cheb(nc,nn)*anorm
+ enddo
+ if(nnaf .lt. nn) then
+ do nc=nnaf+1,nn
+ s0mat(1,nc)=0.
+ s0mat(nn,nc)=0.
+ enddo
+ endif
+ do kc=1,nn
+ s0mat(kc,1)=0.5*s0mat(kc,1)
+ s0mat(kc,nn)=0.5*s0mat(kc,nn)
+ enddo
+ call sgefa(s0mat,nn,nn,is0,info)
+ if(info .ne. 0) stop '21'
+ do kc=1,nn1
+ rvb(kc)=0.
+ enddo
+ rvb(nn)=bpeakbot ! Inner boundary
+ rvb(1)= bpeaktop ! Outer boundary
+ call sgesl(s0mat,nn,nn,is0,rvb,0)
+ do nc=1,nnaf
+ rvb(nc)=rvb(nc)*bscl
+ enddo
+ if(nnaf .lt. nn) then
+ do nc=nnaf+1,nn
+ rvb(nc)=0.
+ enddo
+ endif
+ call chebtf(1,ns2,1,nn1,ns2,rvb,rvb,rvb,wsave,
+ $ work,work(2,1),work(2,1),work(2,1),trigsc,ifaxc,k2k)
+ endif
+c
+c initial entropy and velocity
+c
+ if(init .gt. 0) then
+ do 400 kc=1,nn
+ do 402 lm=1,nlma
+ s(lm,kc)=0.
+ w(lm,kc)=0.
+ z(lm,kc)=0.
+ p(lm,kc)=0.
+ dw(lm,kc)=0.
+ ddw(lm,kc)=0.
+ dz(lm,kc)=0.
+ dwdt(lm,kc,1)=0.
+ dwdt(lm,kc,2)=0.
+ dzdt(lm,kc,1)=0.
+ dzdt(lm,kc,2)=0.
+ dpdt(lm,kc,1)=0.
+ dpdt(lm,kc,2)=0.
+ dsdt(lm,kc,1)=0.
+ dsdt(lm,kc,2)=0.
+ 402 continue
+ 400 continue
+ endif
+c
+ do 410 kc=1,nn
+ do 412 lm=1,nlma
+ b(lm,kc)=0.
+ aj(lm,kc)=0.
+ db(lm,kc)=0.
+ ddb(lm,kc)=0.
+ dj(lm,kc)=0.
+ dbdt(lm,kc,1)=0.
+ dbdt(lm,kc,2)=0.
+ djdt(lm,kc,1)=0.
+ djdt(lm,kc,2)=0.
+ 412 continue
+ 410 continue
+c
+c radial dependence of initial perturbation in rv1
+c
+ do 49 kc=1,nn
+ x=2.*r(kc)-r(1)-r(nn)
+ rv1(kc)=1.-3.*x**2+3.*x**4-x**6
+ 49 continue
+ qllm4max=float(lmax)+0.1
+c
+c random noise initialization
+c
+ if(init .gt. 0 .and. init .lt. 100) then
+ do 85 lm=2,nlma
+ if(ql(lm,4) .gt. qllm4max) go to 85
+ ra1=(-1.+2.*random(0.))*samp
+ ra2=(-1.+2.*random(0.))*samp
+ do 86 kc=1,nn
+ c1=ra1*rv1(kc)
+ c2=ra2*rv1(kc)
+ if(mclm(lm) .gt. 1) then
+ s(lm,kc)=cmplx(c1,c2)
+ else
+ s(lm,kc)=c1
+ endif
+ 86 continue
+ 85 continue
+ do kc=1,nn
+c s(1,kc)=0.
+ s(1,kc)=rva(kc)
+ enddo
+ endif
+c
+c initialize one mode specifically
+c
+ if(init .ge. 100) then
+ m=mod(init,100)
+ if(mod(m,minc).ne.0) stop 'm_init incompatible with minc'
+ l=init/100
+ if(l.gt.lmax.or.l.lt.m) stop 'l_init > lmax or < m_init'
+ lm=m*(lmax+1)/minc-m*(m-minc)/(2*minc)+l-m+1
+ do 88 kc=1,nn
+ c1=rv1(kc)*samp
+ c2=0.0
+ if(mclm(lm) .gt. 1) then
+ s(lm,kc)=cmplx(c1,c2)
+ else
+ s(lm,kc)=c1
+ endif
+ 88 continue
+ do kc=1,nn
+c s(1,kc)=0.
+ s(1,kc)=rva(kc)
+ enddo
+ write(6,'(/'' Initialized at mode l= '',i3,'' m= '',i3/)')
+ $ nint(ql(lm,4)),nint(ql(lm,10))
+ endif
+c
+ if(imagcon .ge. 0) then
+ if(bpeak.gt.0.0) then
+ do kc=1,nn
+ aj(lm0,kc)=rvb(kc)
+ enddo
+ else if(bpeak.lt.0.0) then
+ bpk=2.*bpeak*sqrt(pi/3.)
+ bpp=-4./3.*bpeak*sqrt(pi/5.)
+ do kc=1,nn
+ b(2,kc)=bpk*(.375*r(kc)**3-0.5*r(1)*r(kc)**2
+ $ +r(nn)**4/(8.*r(kc)))
+ aj(3,kc)=bpp*r(kc)*sin(pi*(r(kc)-r(nn)))
+ enddo
+ endif
+ else
+ concof=bpeakbot*bscl*r(nn)
+ do kc=1,nn
+ b(2,kc)=concof*qk(kc,3)
+ enddo
+ endif
+ endif
+c
+c urc: determine scaling factors
+c
+ if(iscale.eq.1) then
+ scdiff=1.
+ else if(iscale.eq.2) then
+ scdiff=opr
+ else
+ scdiff=opm
+ endif
+ tscale= 1./scdiff
+ vscale=scdiff
+ pscale=scdiff*oek
+ escale=scdiff**2 * ocorevol / enscale
+ alum0=opr*radtop*radbot/y00**2
+c
+c -energies
+c
+ if(init .le. 0) then
+ call kei(envp,envt,adrke,amcke)
+ env=envp+envt
+ enbp=0.
+ enbt=0.
+ enb=0.
+ if(init .gt. -10) then
+ call mei(enbp,enbt,apome,atome)
+ enb=enbp+enbt
+ endif
+ else
+ env=0.
+ enb=0.
+ endif
+ write(6,'('' Ekin & Emag= '',2f9.2)') env/escale,enb/escale
+c
+ if(nstep.lt.1) then
+ write(6,'(/'' R T ''/)')
+ do kc=1,nn
+ write(6,'(f8.5,1x,f8.5)')
+ & r(kc)/radtop,real(s(1,kc)-s(1,1))*y00
+ enddo
+ endif
+c
+ write(6,900) ra,ek,pr,prmag
+ 900 format(3x,"rayleigh =",1pe10.3,3x,"ekman =",1pe10.3,/,
+ $3x,"prandtl =",1pe9.2,3x,"mag prandtl =",1pe9.2,/)
+ write(6,904) vscale,pscale,escale
+ 904 format(3x,"scales, V= ",1pe10.3," P= ",1pe10.3,
+ $ " E= ",1pe10.3)
+ if(enscale.ne.1.)
+ $ write(6,'(3x,'' energy multiplied by '',f8.4)') enscale
+ write(6,6) dt/tscale,kstep,time/tscale
+ 6 format(3x,"dt =",f10.8,3x,"kstep =",i7,3x,
+ $"time =",f8.6/)
+c
+c *** construct lu decomposed matrices for w, z, s, b, aj, and p equations
+c
+ call ludc
+c
+ return
+ end
+c
+c*********************************************************************
+c
+ subroutine zerorot(init)
+c
+c For init=-7 or -9, reset time-derivatives of magnetic field to zero
+c For init<=-8, set m=0 terms of toroidal velocity to zero
+c To be used in conjunction with kinematic dynamo runs
+c
+ include 'param.f'
+ include 'com5.f'
+c
+ if(init.eq.-8) go to 10
+ do kc=1,nn
+ do lm=1,nlma
+ dbdt1(lm,kc)=(0.0,0.0)
+ djdt1(lm,kc)=(0.0,0.0)
+ enddo
+ enddo
+c
+ if(init.gt.-8) return
+c
+ 10 do kc=1,nnp1
+ do lm=1,lmax+1
+ z(lm,kc)=(0.0,0.0)
+ enddo
+ enddo
+c
+ return
+ end
Added: 3D/MAG/trunk/src/prnt.f
===================================================================
--- 3D/MAG/trunk/src/prnt.f 2006-06-26 21:27:17 UTC (rev 3892)
+++ 3D/MAG/trunk/src/prnt.f 2006-06-27 00:20:45 UTC (rev 3893)
@@ -0,0 +1,133 @@
+ subroutine prnt
+c
+c---------------------------------------------------------------
+ include 'param.f'
+ include 'com1.f'
+ include 'com3.f'
+ include 'com4.f'
+ include 'com5.f'
+ include 'com8.f'
+c---------------------------------------------------------------
+c
+c urc: modified to find absolute maximum in terms of velocity/field
+c
+ absmax=0.
+ kcmax=0
+ lmmax=0
+ do 6501 kc=1,nn
+ do 6501 lm=2,nlma
+ l=nint(ql(lm,4))
+ a1=l*(l+1)*abs(w(lm,kc))*qk(kc,1)
+ if(a1 .gt. absmax) then
+ absmax=a1
+ kcmax=kc
+ lmmax=lm
+ endif
+ 6501 continue
+ m=mclm(lmmax)-1
+ l=nint(ql(lmmax,4))
+ rad=r(kcmax)-r(nn)
+ write(6,6500) m,l,rad,absmax/vscale
+ 6500 format(/,4x,"w",4x,"m =",i3,4x,"l =",i3,4x,"r =",f7.4,
+ $ 4x,"absmax =",f9.3)
+c
+ absmax=0.
+ kcmax=0
+ lmmax=0
+ do 6601 kc=1,nn
+ do 6601 lm=2,nlma
+ l=nint(ql(lm,4))
+ a1=l*abs(z(lm,kc))*qk(kc,3)
+ if(a1 .gt. absmax) then
+ absmax=a1
+ kcmax=kc
+ lmmax=lm
+ endif
+ 6601 continue
+ m=mclm(lmmax)-1
+ l=nint(ql(lmmax,4))
+ rad=r(kcmax)-r(nn)
+ write(6,6600) m,l,rad,absmax/vscale
+ 6600 format(4x,"z",4x,"m =",i3,4x,"l =",i3,4x,"r =",f7.4,
+ $ 4x,"absmax =",f9.3)
+c
+ absmax=0.
+ kcmax=0
+ lmmax=0
+ do 6701 kc=1,nn
+ do 6701 lm=2,nlma
+ a1=abs(s(lm,kc))
+ if(a1 .gt. absmax) then
+ absmax=a1
+ kcmax=kc
+ lmmax=lm
+ endif
+ 6701 continue
+ m=mclm(lmmax)-1
+ l=nint(ql(lmmax,4))
+ rad=r(kcmax)-r(nn)
+ write(6,6700) m,l,rad,absmax
+ 6700 format(4x,"s",4x,"m =",i3,4x,"l =",i3,4x,"r =",f7.4,
+ $ 4x,"absmax =",f9.5)
+c
+ absmax=0.
+ kcmax=0
+ lmmax=0
+ do 6801 kc=1,nn
+ do 6801 lm=2,nlma
+ a1=abs(p(lm,kc))
+ if(a1 .gt. absmax) then
+ absmax=a1
+ kcmax=kc
+ lmmax=lm
+ endif
+ 6801 continue
+ m=mclm(lmmax)-1
+ l=nint(ql(lmmax,4))
+ rad=r(kcmax)-r(nn)
+ write(6,6800) m,l,rad,absmax/pscale
+ 6800 format(4x,"p",4x,"m =",i3,4x,"l =",i3,4x,"r =",f7.4,
+ $ 4x,"absmax =",f9.4)
+c
+ absmax=0.
+ kcmax=0
+ lmmax=0
+ do 691 kc=1,nn
+ do 691 lm=2,nlma
+ l=nint(ql(lm,4))
+ a1=l*(l+1)*abs(b(lm,kc))*qk(kc,1)
+ if(a1 .gt. absmax) then
+ absmax=a1
+ kcmax=kc
+ lmmax=lm
+ endif
+ 691 continue
+ m=mclm(lmmax)-1
+ l=nint(ql(lmmax,4))
+ rad=r(kcmax)-r(nn)
+ write(6,690) m,l,rad,absmax
+ 690 format(4x,"b",4x,"m =",i3,4x,"l =",i3,4x,"r =",f7.4,
+ $ 4x,"absmax =",f9.5)
+c
+ absmax=0.
+ kcmax=0
+ lmmax=0
+ do 701 kc=1,nn
+ do 701 lm=2,nlma
+ l=nint(ql(lm,4))
+ a1=l*abs(aj(lm,kc))*qk(kc,3)
+ if(a1 .gt. absmax) then
+ absmax=a1
+ kcmax=kc
+ lmmax=lm
+ endif
+ 701 continue
+ m=mclm(lmmax)-1
+ l=nint(ql(lmmax,4))
+ rad=r(kcmax)-r(nn)
+ write(6,700) m,l,rad,absmax
+ 700 format(4x,"j",4x,"m =",i3,4x,"l =",i3,4x,"r =",f7.4,
+ $ 4x,"absmax =",f9.5)
+c
+ return
+ end
Added: 3D/MAG/trunk/src/random.f
===================================================================
--- 3D/MAG/trunk/src/random.f 2006-06-26 21:27:17 UTC (rev 3892)
+++ 3D/MAG/trunk/src/random.f 2006-06-27 00:20:45 UTC (rev 3893)
@@ -0,0 +1,41 @@
+ function random(r)
+c
+c random number generator
+c
+c if(r .eq. 0.) then
+c random(r) = next random number (between 0. and 1.)
+c else if(r .lt. 0.) then
+c random(r) = previous random number
+c else if(r .gt. 0.) then
+c random(r) = a new sequence of random numbers is started
+c with seed r mod 1
+c note: r must be a non-integer to get a different seq
+c endif
+c
+c called in prep
+c
+ save ia1, ia0, ia1ma0, ic, ix1, ix0
+ data ia1, ia0, ia1ma0 /1536, 1029, 507/
+ data ic /1731/
+ data ix1, ix0 /0, 0/
+c
+ if (r.lt.0.) go to 10
+ if (r.gt.0.) go to 20
+c
+ iy0 = ia0*ix0
+ iy1 = ia1*ix1 + ia1ma0*(ix0-ix1) + iy0
+ iy0 = iy0 + ic
+ ix0 = mod (iy0, 2048)
+ iy1 = iy1 + (iy0-ix0)/2048
+ ix1 = mod (iy1, 2048)
+c
+ 10 random = ix1*2048 + ix0
+ random = random / 4194304.
+ return
+c
+ 20 ix1 = mod(r,1.)*4194304. + 0.5
+ ix0 = mod (ix1, 2048)
+ ix1 = (ix1-ix0)/2048
+ go to 10
+c
+ end
Added: 3D/MAG/trunk/src/rderiv.f
===================================================================
--- 3D/MAG/trunk/src/rderiv.f 2006-06-26 21:27:17 UTC (rev 3892)
+++ 3D/MAG/trunk/src/rderiv.f 2006-06-27 00:20:45 UTC (rev 3893)
@@ -0,0 +1,42 @@
+ subroutine rderiv(od,anorm,f,df)
+c
+c calculates derivative of Chebychev polynomia
+c called in prep
+c
+c---------------------------------------------------------------
+ include 'param.f'
+ include 'com7.f'
+c
+ dimension f(*),df(*),g(nn)
+c---------------------------------------------------------------
+c
+ do 10 nc=1,nn
+ df(nc)=0.5*(f(1)+f(nn)*cheb(nc,nn))
+ 10 continue
+ do 11 kc=2,nn1
+ do 11 nc=1,nn
+ df(nc)=df(nc)+f(kc)*cheb(nc,kc)
+ 11 continue
+ do 12 nc=1,nn
+ df(nc)=anorm*df(nc)
+ 12 continue
+c
+ g(nn)=0.
+ g(nn1)=float(nn1)*df(nn)
+ do 20 n=nn2,1,-1
+ g(n)=g(n+2)+float(2*n)*df(n+1)
+ 20 continue
+c
+ do 30 kc=1,nn
+ df(kc)=0.5*g(nn)*cheb(nn,kc)
+ 30 continue
+ do 31 nc=nn1,2,-1
+ do 31 kc=1,nn
+ df(kc)=df(kc)+g(nc)*cheb(nc,kc)
+ 31 continue
+ do 32 kc=1,nn
+ df(kc)=2.*anorm*(df(kc)+0.5*g(1))
+ 32 continue
+c
+ return
+ end
Added: 3D/MAG/trunk/src/rffti.f
===================================================================
--- 3D/MAG/trunk/src/rffti.f 2006-06-26 21:27:17 UTC (rev 3892)
+++ 3D/MAG/trunk/src/rffti.f 2006-06-27 00:20:45 UTC (rev 3893)
@@ -0,0 +1,22 @@
+ subroutine rffti(n,wsave)
+c
+c called in chebi
+c
+ dimension wsave(*)
+c
+ ns2 = n/2
+ nqm = (ns2-1)/2
+ tpi = 8.*atan(1.)
+ dt = tpi/float(n)
+ dc = cos(dt)
+ ds = sin(dt)
+ wsave(1) = dc
+ wsave(ns2-1) = ds
+ if (nqm .lt. 2) return
+ do 101 k=2,nqm
+ kc = ns2-k
+ wsave(k) = dc*wsave(k-1)-ds*wsave(kc+1)
+ wsave(kc) = ds*wsave(k-1)+dc*wsave(kc+1)
+ 101 continue
+ return
+ end
Added: 3D/MAG/trunk/src/sgefa.f
===================================================================
--- 3D/MAG/trunk/src/sgefa.f 2006-06-26 21:27:17 UTC (rev 3892)
+++ 3D/MAG/trunk/src/sgefa.f 2006-06-27 00:20:45 UTC (rev 3893)
@@ -0,0 +1,50 @@
+ subroutine sgefa(a,ia,n,ip,info)
+c
+c *******************************************************************
+c like the linpack routine
+c
+c lu decomposes the real matrix a(n,n) via gaussian elimination
+c
+c called in ludc and prep
+c *******************************************************************
+c
+ dimension a(ia,n),ip(n)
+c
+ if(n .le. 1) stop '45'
+ info=0
+ nm1=n-1
+c
+ do 50 k=1,nm1
+ kp1=k+1
+ l=k
+ do 60 i=kp1,n
+ if(abs(a(i,k)) .gt. abs(a(l,k))) l=i
+ 60 continue
+ ip(k)=l
+ if(a(l,k) .eq. 0.) go to 40
+ if(l .eq. k) go to 10
+ do 70 i=1,n
+ t=a(k,i)
+ a(k,i)=a(l,i)
+ a(l,i)=t
+ 70 continue
+ 10 continue
+ t=1./a(k,k)
+ do 80 i=kp1,n
+ a(i,k)=t*a(i,k)
+ 80 continue
+ do 30 j=kp1,n
+ do 90 i=kp1,n
+ a(i,j)=a(i,j)-a(k,j)*a(i,k)
+ 90 continue
+ 30 continue
+ go to 50
+ 40 continue
+ info=k
+ 50 continue
+c
+ ip(n)=n
+ if(a(n,n) .eq. 0.) info=n
+c
+ return
+ end
Added: 3D/MAG/trunk/src/sgesl.f
===================================================================
--- 3D/MAG/trunk/src/sgesl.f 2006-06-26 21:27:17 UTC (rev 3892)
+++ 3D/MAG/trunk/src/sgesl.f 2006-06-27 00:20:45 UTC (rev 3893)
@@ -0,0 +1,55 @@
+ subroutine sgesl(a,ia,n,ip,b,ijob)
+c
+c ************************************************************
+c like the linpack routine
+c
+c solves a * x = b via lu decomposition
+c
+c sub sgefa must be called once first to initialize a and ip
+c
+c n is the order of the linear matrix equation
+c
+c ia .ge. n .gt. 1
+c
+c on return, the solution vector x is stored in b
+c
+c called in amhd and prep
+c ************************************************************
+c
+ dimension a(ia,*),b(*),ip(*)
+c
+ np1=n+1
+ nm1=n-1
+c urc if(ijob .ne. 0) stop '44'
+c
+c permute vector b
+c
+ do 1 k=1,nm1
+ m=ip(k)
+ if(m .eq. k) go to 1
+ c=b(m)
+ b(m)=b(k)
+ b(k)=c
+ 1 continue
+c
+c solve l * y = b
+c
+ do 2 k=1,nm1
+ kp1=k+1
+ do 2 i=kp1,n
+ b(i)=b(i)-b(k)*a(i,k)
+ 2 continue
+c
+c solve u * x = y
+c
+ do 3 kb=1,nm1
+ k=np1-kb
+ b(k)=b(k)/a(k,k)
+ km1=k-1
+ do 3 i=1,km1
+ b(i)=b(i)-b(k)*a(i,k)
+ 3 continue
+ b(1)=b(1)/a(1,1)
+c
+ return
+ end
Added: 3D/MAG/trunk/src/spectrum.f
===================================================================
--- 3D/MAG/trunk/src/spectrum.f 2006-06-26 21:27:17 UTC (rev 3892)
+++ 3D/MAG/trunk/src/spectrum.f 2006-06-27 00:20:45 UTC (rev 3893)
@@ -0,0 +1,229 @@
+ subroutine spectrum(imode)
+c
+c---------------------------------------------------------------
+c
+c calculation of power spectrum of kinetic and magnetic energy as
+c function of harmonic degree (urc)
+c
+c imode=0: sum all modes of given l and various m
+c imode=1: sum all modes of given m and various l
+c
+c called in amhd
+c
+c---------------------------------------------------------------
+c
+ include 'param.f'
+ include 'com1.f'
+ include 'com3.f'
+ include 'com4.f'
+ include 'com5.f'
+ include 'com8.f'
+c
+ complex c
+c
+ dimension ekin(0:nlaf)
+ dimension emag(0:nlaf)
+ dimension emcmb(0:9)
+ dimension vtcmb(0:nlaf)
+ dimension vpcmb(0:nlaf)
+ dimension rvl(nn,0:nlaf)
+ dimension rvm(nn,0:nlaf)
+c
+c rvl(nn,0) assembles the axisymmetric portion of kinetic energy
+c rvm(nn,0) assembles the axisymmetric portion of kinetic energy
+c
+ cabssq(c)=real(c)**2+aimag(c)**2
+c---------------------------------------------------------------
+c
+ isort=5
+ lblock=(nlaf-1)/10+1
+ lstep=1
+ lc0=0
+ if(imode.gt.0) then
+ isort=10
+ lblock=(nlaf-1)/(10*minc)+1
+ lstep=minc
+ lc0=1
+ endif
+c
+ do 20 lc=0,nlaf
+ do 20 kc=1,nn
+ rvl(kc,lc)=0.
+ rvm(kc,lc)=0.
+ 20 continue
+ do 22 lc=0,9
+ emcmb(lc)=0.0
+ 22 continue
+ polmag=0.0
+ polaxi=0.0
+c
+ do 30 lm=nlma,2,-1
+ lc=ql(lm,isort)+lc0
+ do 31 kc=1,nn
+ rvl(kc,lc)=rvl(kc,lc)+
+ $ ql(lm,6)*(ql(lm,3)*qk(kc,1)*cabssq(w(lm,kc))+
+ $ cabssq(z(lm,kc))+4.*cabssq(dw(lm,kc)))
+ rvm(kc,lc)=rvm(kc,lc)+
+ $ ql(lm,6)*(ql(lm,3)*qk(kc,1)*cabssq(b(lm,kc))+
+ $ cabssq(aj(lm,kc))+4.*cabssq(db(lm,kc)))
+ 31 continue
+ if(imode.lt.1.and.ql(lm,10).lt.0.1) then
+ do 32 kc=1,nn
+ rvl(kc,0)=rvl(kc,0)+
+ $ ql(lm,6)*(ql(lm,3)*qk(kc,1)*cabssq(w(lm,kc))+
+ $ cabssq(z(lm,kc))+4.*cabssq(dw(lm,kc)))
+ rvm(kc,0)=rvm(kc,0)+
+ $ ql(lm,6)*(ql(lm,3)*qk(kc,1)*cabssq(b(lm,kc))+
+ $ cabssq(aj(lm,kc))+4.*cabssq(db(lm,kc)))
+ 32 continue
+ polaxi=polaxi +
+ $ ql(lm,6)*(ql(lm,3)*qk(1,1)*cabssq(b(lm,1))
+ $ +4.*cabssq(db(lm,1)))
+ endif
+ if(imode.lt.1) then
+ polmag=polmag +
+ $ ql(lm,6)*(ql(lm,3)*qk(1,1)*cabssq(b(lm,1))
+ $ +4.*cabssq(db(lm,1)))
+ lc=nint(ql(lm,4))
+ vpcmb(lc)=vtcmb(lc)+
+ $ ql(lm,6)*(ql(lm,3)*qk(1,1)*cabssq(w(lm,1))
+ $ +4.*cabssq(dw(lm,1)))
+ vtcmb(lc)=vtcmb(lc)+
+ $ ql(lm,6)*cabssq(z(lm,1))
+ endif
+ if(imode.lt.1 .and. ql(lm,4).lt.10) then
+ lc=nint(ql(lm,4))
+ emcmb(lc)=emcmb(lc) +
+ $ ql(lm,6)*(ql(lm,3)*qk(1,1)*cabssq(b(lm,1))
+ $ +4.*cabssq(db(lm,1)))
+ endif
+c
+ 30 continue
+c
+ surface=4.*pi*radtop*radtop
+ dipolax=sqrt(2.*ql(2,6)*(ql(2,3)*qk(1,1)*cabssq(b(2,1))
+ $ +4.*cabssq(db(2,1))) /surface)
+ dipole=dipolax
+ if(minc.eq.1) then
+ lm=lmax+2
+ dipole=sqrt(dipolax**2 +
+ $ 2.*ql(lm,6)*(ql(lm,3)*qk(1,1)*cabssq(b(lm,1))
+ $ +4.*cabssq(db(lm,1))) /surface)
+ endif
+ polmag=sqrt(2.*polmag/surface)
+ polaxi=sqrt(2.*polaxi/surface)
+c
+ do 33 lc=0,9
+ emcmb(lc)=2.*emcmb(lc)/surface
+ 33 continue
+ do 34 lc=1,nlaf
+ vpcmb(lc)=2.*vpcmb(lc)/surface
+ vtcmb(lc)=2.*vtcmb(lc)/surface
+ 34 continue
+c
+ ekinmax=0.0
+ ekinaxi=0.0
+ ekinsum=0.0
+ emagmax=0.0
+ emagaxi=0.0
+ emagsum=0.0
+c
+ do 50 lc=0,nlaf
+c
+ call chebtf(1,ns2,1,nn1,ns2,rvl(1,lc),rvl(1,lc),rvl(1,lc),
+ $ wsave,work,work(2,1),work(2,1),work(2,1),trigsc,ifaxc,k2k)
+ call chebtf(1,ns2,1,nn1,ns2,rvm(1,lc),rvm(1,lc),rvm(1,lc),
+ $ wsave,work,work(2,1),work(2,1),work(2,1),trigsc,ifaxc,k2k)
+c
+ ekin(lc)=0.0
+ emag(lc)=0.0
+ rvl(1,lc)=0.5*rvl(1,lc)
+ rvl(nn,lc)=0.5*rvl(nn,lc)
+ rvm(1,lc)=0.5*rvm(1,lc)
+ rvm(nn,lc)=0.5*rvm(nn,lc)
+ do 45 ncb=1,nn,2
+ nc=nnp1-ncb
+ ekin(lc)=ekin(lc)+rvl(nc,lc)*qn(nc,3)
+ emag(lc)=emag(lc)+rvm(nc,lc)*qn(nc,3)
+ 45 continue
+ ekin(lc)=0.5*anorm*ekin(lc)
+ if(ekin(lc).gt.ekinmax) ekinmax=ekin(lc)
+ if(lc.gt.0) ekinsum=ekinsum+ekin(lc)
+ emag(lc)=0.5*oekpm*anorm*emag(lc)
+ if(emag(lc).gt.emagmax) emagmax=emag(lc)
+ if(lc.gt.0) emagsum=emagsum+emag(lc)
+ 50 continue
+c
+c print
+c
+ ekinaxi=ekin(0)/escale
+ ekinsum=ekinsum/escale
+ emagaxi=emag(0)/escale
+ emagsum=emagsum/escale
+ dipolax=sign(dipolax,real(b(2,1)))
+ dipole=dipole
+ polmag=polmag
+ polaxi=polaxi
+ tiltdipole=0.0
+ if(minc.eq.1)
+ $ tiltdipole=atan2(abs(b(lmax+2,1)),real(b(2,1)))
+c
+ if(imode.lt.1) then
+ write(6,'('' Spectrum Ekin vs l Total/Axisym.= '',
+ $ 2f9.2 )') ekinsum,ekinaxi
+ write(6,'(10(2x,i3,3x))') (l,l=0,9)
+ else
+ write(6,'('' Spectrum Ekin vs m Total = '',
+ $ 1f9.2 )') ekinsum
+ write(6,'(10(2x,i3,3x))') (l,l=0,9*lstep,lstep)
+ endif
+ do 60 lb=1,lblock
+ l0=(lb-1)*10*lstep
+ l1=min(l0+9*lstep,nlaf-1)
+ write(6,'(10(f8.2))') (ekin(l+1)/escale,l=l0,l1,lstep)
+ 60 continue
+c
+ if(imode.lt.1) then
+ write(6,'(/'' Poloidal/Toroidal Ekin (x10) at CMB'')')
+ write(6,'(10(2x,i3,3x))') (l,l=0,9)
+ do 61 lb=1,lblock
+ l0=(lb-1)*10*lstep
+ l1=min(l0+9*lstep,nlaf-1)
+ write(6,'(10(f8.2))') (10.*vpcmb(l+1)/escale,l=l0,l1,lstep)
+ write(6,'(10(f8.2)/)') (10.*vtcmb(l+1)/escale,l=l0,l1,lstep)
+ 61 continue
+ write(6,'(/'' CMB field: Total='',f7.4,
+ $ '' Axi='',f7.4,'' Dipole='',f7.4,'' Ax.Dip.='',
+ $ f7.4,'' Tilt='',f5.1)')
+ $ polmag,polaxi,dipole,dipolax,tiltdipole*180./pi
+ write(6,'('' Spectrum Emag vs l Total/Axisym.= '',
+ $ 2f9.2 )') emagsum,emagaxi
+ write(6,'(10(2x,i3,3x))') (l,l=0,9)
+ write(6,'('' CMB: '',9f8.5)') (emcmb(l),l=1,9)
+ else
+ write(6,'('' Spectrum Emag vs m Total = '',
+ $ 1f9.2 )') emagsum
+ write(6,'(10(2x,i3,3x))') (l,l=0,9*lstep,lstep)
+ endif
+ do 70 lb=1,lblock
+ l0=(lb-1)*10*lstep
+ l1=min(l0+9*lstep,nlaf-1)
+ write(6,'(10(f8.2))') (emag(l+1)/escale,l=l0,l1,lstep)
+ 70 continue
+c
+c output on logs-file
+c
+ if(imode.lt.1) then
+ write(16,'(f9.6,1x,65f10.4)') time/tscale,(ekin(l)/escale,
+ & l=1,nlaf)
+ write(16,'(f9.6,1x,65f10.4)') time/tscale,(emag(l)/escale,
+ & l=1,nlaf,lstep)
+ else
+ write(16,'(f9.6,1x,65f10.4)') time/tscale,(ekin(l)/escale,
+ & l=1,nlaf,lstep)
+ write(16,'(f9.6,1x,65f10.4)') time/tscale,(emag(l)/escale,
+ & l=1,nlaf,lstep)
+ endif
+c
+ return
+ end
Added: 3D/MAG/trunk/src/spherictf.f
===================================================================
--- 3D/MAG/trunk/src/spherictf.f 2006-06-26 21:27:17 UTC (rev 3892)
+++ 3D/MAG/trunk/src/spherictf.f 2006-06-27 00:20:45 UTC (rev 3893)
@@ -0,0 +1,31 @@
+ subroutine spherictf(alm,aij)
+c
+c -spherical harmonic transform from alm(l,m) to aij(i,j)
+c
+c---------------------------------------------------------------
+ include 'param.f'
+ include 'com4.f'
+c
+ complex
+ $cs1(nlma),alm(nlma),aij(ncp,ni)
+c
+ do 201 ic=1,ni
+ do 202 mca=1,ncp
+ aij(mca,ic)=0.
+ 202 continue
+ 201 continue
+c
+ do 203 lm=nlma,2,-1
+ cs1(lm)=alm(lm)*ql(lm,3)
+ 203 continue
+c
+ do 204 ic=1,ni
+ do 204 lm=nlma,2,-1
+ mca=mclma(lm)
+ aij(mca,ic)=aij(mca,ic)+cs1(lm)*aleg1(lm,ic)
+ 204 continue
+c
+ call fourtf(aij,work,trigsf,ifaxf,1,nrp,nja,ni,1)
+c
+ return
+ end
Added: 3D/MAG/trunk/src/stopiteration.f
===================================================================
--- 3D/MAG/trunk/src/stopiteration.f 2006-06-26 21:27:17 UTC (rev 3892)
+++ 3D/MAG/trunk/src/stopiteration.f 2006-06-27 00:20:45 UTC (rev 3893)
@@ -0,0 +1,8 @@
+ subroutine stopiteration
+c
+c called in amhd
+c
+ common/stop/ istop
+ istop=1
+ return
+ end
Added: 3D/MAG/trunk/src/stor.f
===================================================================
--- 3D/MAG/trunk/src/stor.f 2006-06-26 21:27:17 UTC (rev 3892)
+++ 3D/MAG/trunk/src/stor.f 2006-06-27 00:20:45 UTC (rev 3893)
@@ -0,0 +1,25 @@
+ subroutine stor
+c
+c---------------------------------------------------------------
+ include 'param.f'
+ include 'com1.f'
+ include 'com3.f'
+ include 'com4.f'
+ include 'com5.f'
+c---------------------------------------------------------------
+c
+c *** store output
+c
+ rewind(10)
+ write(10) time,dt,ra,pr,prmag,ek,radratio,
+ $ kstep,nn,ni,nj,minc
+ write(10) w,z,p,s
+ write(10) dsdt1,dwdt1,dzdt1,dpdt1
+ write(10) b,aj,dbdt1,djdt1
+c
+ if(iprnt .eq. nprnt) close(10)
+ write(6,1) rstfile
+ 1 format(/,8x,"** restart data stored in ",a32," **",/)
+c
+ return
+ end
Added: 3D/MAG/trunk/src/vpassm.f
===================================================================
--- 3D/MAG/trunk/src/vpassm.f 2006-06-26 21:27:17 UTC (rev 3892)
+++ 3D/MAG/trunk/src/vpassm.f 2006-06-27 00:20:45 UTC (rev 3893)
@@ -0,0 +1,321 @@
+ subroutine vpassm(a,b,c,d,trigs,inc1,inc2,inc3,inc4,lot,n,ifac,la)
+c
+c called in chebtf and fourtf
+c
+ dimension a(*),b(*),c(*),d(*),trigs(*)
+ data sin36/0.587785252292473/,cos36/0.809016994374947/,
+ * sin72/0.951056516295154/,cos72/0.309016994374947/,
+ * sin60/0.866025403784437/
+c
+ m=n/ifac
+ iink=m*inc1
+ jink=la*inc2
+ jump=(ifac-1)*jink
+ ibase=0
+ jbase=0
+ igo=ifac-1
+ if (igo.gt.4) return
+ go to (10,50,90,130),igo
+c
+c coding for factor 2
+c
+ 10 ia=1
+ ja=1
+ ib=ia+iink
+ jb=ja+jink
+ do 20 l=1,la
+ i=ibase
+ j=jbase
+c dir$ ivdep
+ do 15 ijk=1,lot
+ c(ja+j)=a(ia+i)+a(ib+i)
+ d(ja+j)=b(ia+i)+b(ib+i)
+ c(jb+j)=a(ia+i)-a(ib+i)
+ d(jb+j)=b(ia+i)-b(ib+i)
+ i=i+inc3
+ j=j+inc4
+ 15 continue
+ ibase=ibase+inc1
+ jbase=jbase+inc2
+ 20 continue
+ if (la.eq.m) return
+ la1=la+1
+ jbase=jbase+jump
+ do 40 k=la1,m,la
+ kb=k+k-2
+ c1=trigs(kb+1)
+ s1=trigs(kb+2)
+ do 30 l=1,la
+ i=ibase
+ j=jbase
+c dir$ ivdep
+ do 25 ijk=1,lot
+ c(ja+j)=a(ia+i)+a(ib+i)
+ d(ja+j)=b(ia+i)+b(ib+i)
+ c(jb+j)=c1*(a(ia+i)-a(ib+i))-s1*(b(ia+i)-b(ib+i))
+ d(jb+j)=s1*(a(ia+i)-a(ib+i))+c1*(b(ia+i)-b(ib+i))
+ i=i+inc3
+ j=j+inc4
+ 25 continue
+ ibase=ibase+inc1
+ jbase=jbase+inc2
+ 30 continue
+ jbase=jbase+jump
+ 40 continue
+ return
+c
+c coding for factor 3
+c
+ 50 ia=1
+ ja=1
+ ib=ia+iink
+ jb=ja+jink
+ ic=ib+iink
+ jc=jb+jink
+ do 60 l=1,la
+ i=ibase
+ j=jbase
+c dir$ ivdep
+ do 55 ijk=1,lot
+ c(ja+j)=a(ia+i)+(a(ib+i)+a(ic+i))
+ d(ja+j)=b(ia+i)+(b(ib+i)+b(ic+i))
+ c(jb+j)=(a(ia+i)-0.5*(a(ib+i)+a(ic+i)))-(sin60*(b(ib+i)-b(ic+i)))
+ c(jc+j)=(a(ia+i)-0.5*(a(ib+i)+a(ic+i)))+(sin60*(b(ib+i)-b(ic+i)))
+ d(jb+j)=(b(ia+i)-0.5*(b(ib+i)+b(ic+i)))+(sin60*(a(ib+i)-a(ic+i)))
+ d(jc+j)=(b(ia+i)-0.5*(b(ib+i)+b(ic+i)))-(sin60*(a(ib+i)-a(ic+i)))
+ i=i+inc3
+ j=j+inc4
+ 55 continue
+ ibase=ibase+inc1
+ jbase=jbase+inc2
+ 60 continue
+ if (la.eq.m) return
+ la1=la+1
+ jbase=jbase+jump
+ do 80 k=la1,m,la
+ kb=k+k-2
+ kc=kb+kb
+ c1=trigs(kb+1)
+ s1=trigs(kb+2)
+ c2=trigs(kc+1)
+ s2=trigs(kc+2)
+ do 70 l=1,la
+ i=ibase
+ j=jbase
+c dir$ ivdep
+ do 65 ijk=1,lot
+ c(ja+j)=a(ia+i)+(a(ib+i)+a(ic+i))
+ d(ja+j)=b(ia+i)+(b(ib+i)+b(ic+i))
+ c(jb+j)=
+ * c1*((a(ia+i)-0.5*(a(ib+i)+a(ic+i)))-(sin60*(b(ib+i)-b(ic+i))))
+ * -s1*((b(ia+i)-0.5*(b(ib+i)+b(ic+i)))+(sin60*(a(ib+i)-a(ic+i))))
+ d(jb+j)=
+ * s1*((a(ia+i)-0.5*(a(ib+i)+a(ic+i)))-(sin60*(b(ib+i)-b(ic+i))))
+ * +c1*((b(ia+i)-0.5*(b(ib+i)+b(ic+i)))+(sin60*(a(ib+i)-a(ic+i))))
+ c(jc+j)=
+ * c2*((a(ia+i)-0.5*(a(ib+i)+a(ic+i)))+(sin60*(b(ib+i)-b(ic+i))))
+ * -s2*((b(ia+i)-0.5*(b(ib+i)+b(ic+i)))-(sin60*(a(ib+i)-a(ic+i))))
+ d(jc+j)=
+ * s2*((a(ia+i)-0.5*(a(ib+i)+a(ic+i)))+(sin60*(b(ib+i)-b(ic+i))))
+ * +c2*((b(ia+i)-0.5*(b(ib+i)+b(ic+i)))-(sin60*(a(ib+i)-a(ic+i))))
+ i=i+inc3
+ j=j+inc4
+ 65 continue
+ ibase=ibase+inc1
+ jbase=jbase+inc2
+ 70 continue
+ jbase=jbase+jump
+ 80 continue
+ return
+c
+c coding for factor 4
+c
+ 90 ia=1
+ ja=1
+ ib=ia+iink
+ jb=ja+jink
+ ic=ib+iink
+ jc=jb+jink
+ id=ic+iink
+ jd=jc+jink
+ do 100 l=1,la
+ i=ibase
+ j=jbase
+c dir$ ivdep
+ do 95 ijk=1,lot
+ c(ja+j)=(a(ia+i)+a(ic+i))+(a(ib+i)+a(id+i))
+ c(jc+j)=(a(ia+i)+a(ic+i))-(a(ib+i)+a(id+i))
+ d(ja+j)=(b(ia+i)+b(ic+i))+(b(ib+i)+b(id+i))
+ d(jc+j)=(b(ia+i)+b(ic+i))-(b(ib+i)+b(id+i))
+ c(jb+j)=(a(ia+i)-a(ic+i))-(b(ib+i)-b(id+i))
+ c(jd+j)=(a(ia+i)-a(ic+i))+(b(ib+i)-b(id+i))
+ d(jb+j)=(b(ia+i)-b(ic+i))+(a(ib+i)-a(id+i))
+ d(jd+j)=(b(ia+i)-b(ic+i))-(a(ib+i)-a(id+i))
+ i=i+inc3
+ j=j+inc4
+ 95 continue
+ ibase=ibase+inc1
+ jbase=jbase+inc2
+ 100 continue
+ if (la.eq.m) return
+ la1=la+1
+ jbase=jbase+jump
+ do 120 k=la1,m,la
+ kb=k+k-2
+ kc=kb+kb
+ kd=kc+kb
+ c1=trigs(kb+1)
+ s1=trigs(kb+2)
+ c2=trigs(kc+1)
+ s2=trigs(kc+2)
+ c3=trigs(kd+1)
+ s3=trigs(kd+2)
+ do 110 l=1,la
+ i=ibase
+ j=jbase
+c dir$ ivdep
+ do 105 ijk=1,lot
+ c(ja+j)=(a(ia+i)+a(ic+i))+(a(ib+i)+a(id+i))
+ d(ja+j)=(b(ia+i)+b(ic+i))+(b(ib+i)+b(id+i))
+ c(jc+j)=
+ * c2*((a(ia+i)+a(ic+i))-(a(ib+i)+a(id+i)))
+ * -s2*((b(ia+i)+b(ic+i))-(b(ib+i)+b(id+i)))
+ d(jc+j)=
+ * s2*((a(ia+i)+a(ic+i))-(a(ib+i)+a(id+i)))
+ * +c2*((b(ia+i)+b(ic+i))-(b(ib+i)+b(id+i)))
+ c(jb+j)=
+ * c1*((a(ia+i)-a(ic+i))-(b(ib+i)-b(id+i)))
+ * -s1*((b(ia+i)-b(ic+i))+(a(ib+i)-a(id+i)))
+ d(jb+j)=
+ * s1*((a(ia+i)-a(ic+i))-(b(ib+i)-b(id+i)))
+ * +c1*((b(ia+i)-b(ic+i))+(a(ib+i)-a(id+i)))
+ c(jd+j)=
+ * c3*((a(ia+i)-a(ic+i))+(b(ib+i)-b(id+i)))
+ * -s3*((b(ia+i)-b(ic+i))-(a(ib+i)-a(id+i)))
+ d(jd+j)=
+ * s3*((a(ia+i)-a(ic+i))+(b(ib+i)-b(id+i)))
+ * +c3*((b(ia+i)-b(ic+i))-(a(ib+i)-a(id+i)))
+ i=i+inc3
+ j=j+inc4
+ 105 continue
+ ibase=ibase+inc1
+ jbase=jbase+inc2
+ 110 continue
+ jbase=jbase+jump
+ 120 continue
+ return
+c
+c coding for factor 5
+c
+ 130 ia=1
+ ja=1
+ ib=ia+iink
+ jb=ja+jink
+ ic=ib+iink
+ jc=jb+jink
+ id=ic+iink
+ jd=jc+jink
+ ie=id+iink
+ je=jd+jink
+ do 140 l=1,la
+ i=ibase
+ j=jbase
+c dir$ ivdep
+ do 135 ijk=1,lot
+ c(ja+j)=a(ia+i)+(a(ib+i)+a(ie+i))+(a(ic+i)+a(id+i))
+ d(ja+j)=b(ia+i)+(b(ib+i)+b(ie+i))+(b(ic+i)+b(id+i))
+ c(jb+j)=(a(ia+i)+cos72*(a(ib+i)+a(ie+i))-cos36*(a(ic+i)+a(id+i)))
+ * -(sin72*(b(ib+i)-b(ie+i))+sin36*(b(ic+i)-b(id+i)))
+ c(je+j)=(a(ia+i)+cos72*(a(ib+i)+a(ie+i))-cos36*(a(ic+i)+a(id+i)))
+ * +(sin72*(b(ib+i)-b(ie+i))+sin36*(b(ic+i)-b(id+i)))
+ d(jb+j)=(b(ia+i)+cos72*(b(ib+i)+b(ie+i))-cos36*(b(ic+i)+b(id+i)))
+ * +(sin72*(a(ib+i)-a(ie+i))+sin36*(a(ic+i)-a(id+i)))
+ d(je+j)=(b(ia+i)+cos72*(b(ib+i)+b(ie+i))-cos36*(b(ic+i)+b(id+i)))
+ * -(sin72*(a(ib+i)-a(ie+i))+sin36*(a(ic+i)-a(id+i)))
+ c(jc+j)=(a(ia+i)-cos36*(a(ib+i)+a(ie+i))+cos72*(a(ic+i)+a(id+i)))
+ * -(sin36*(b(ib+i)-b(ie+i))-sin72*(b(ic+i)-b(id+i)))
+ c(jd+j)=(a(ia+i)-cos36*(a(ib+i)+a(ie+i))+cos72*(a(ic+i)+a(id+i)))
+ * +(sin36*(b(ib+i)-b(ie+i))-sin72*(b(ic+i)-b(id+i)))
+ d(jc+j)=(b(ia+i)-cos36*(b(ib+i)+b(ie+i))+cos72*(b(ic+i)+b(id+i)))
+ * +(sin36*(a(ib+i)-a(ie+i))-sin72*(a(ic+i)-a(id+i)))
+ d(jd+j)=(b(ia+i)-cos36*(b(ib+i)+b(ie+i))+cos72*(b(ic+i)+b(id+i)))
+ * -(sin36*(a(ib+i)-a(ie+i))-sin72*(a(ic+i)-a(id+i)))
+ i=i+inc3
+ j=j+inc4
+ 135 continue
+ ibase=ibase+inc1
+ jbase=jbase+inc2
+ 140 continue
+ if (la.eq.m) return
+ la1=la+1
+ jbase=jbase+jump
+ do 160 k=la1,m,la
+ kb=k+k-2
+ kc=kb+kb
+ kd=kc+kb
+ ke=kd+kb
+ c1=trigs(kb+1)
+ s1=trigs(kb+2)
+ c2=trigs(kc+1)
+ s2=trigs(kc+2)
+ c3=trigs(kd+1)
+ s3=trigs(kd+2)
+ c4=trigs(ke+1)
+ s4=trigs(ke+2)
+ do 150 l=1,la
+ i=ibase
+ j=jbase
+c dir$ ivdep
+ do 145 ijk=1,lot
+ c(ja+j)=a(ia+i)+(a(ib+i)+a(ie+i))+(a(ic+i)+a(id+i))
+ d(ja+j)=b(ia+i)+(b(ib+i)+b(ie+i))+(b(ic+i)+b(id+i))
+ c(jb+j)=
+ * c1*((a(ia+i)+cos72*(a(ib+i)+a(ie+i))-cos36*(a(ic+i)+a(id+i)))
+ * -(sin72*(b(ib+i)-b(ie+i))+sin36*(b(ic+i)-b(id+i))))
+ * -s1*((b(ia+i)+cos72*(b(ib+i)+b(ie+i))-cos36*(b(ic+i)+b(id+i)))
+ * +(sin72*(a(ib+i)-a(ie+i))+sin36*(a(ic+i)-a(id+i))))
+ d(jb+j)=
+ * s1*((a(ia+i)+cos72*(a(ib+i)+a(ie+i))-cos36*(a(ic+i)+a(id+i)))
+ * -(sin72*(b(ib+i)-b(ie+i))+sin36*(b(ic+i)-b(id+i))))
+ * +c1*((b(ia+i)+cos72*(b(ib+i)+b(ie+i))-cos36*(b(ic+i)+b(id+i)))
+ * +(sin72*(a(ib+i)-a(ie+i))+sin36*(a(ic+i)-a(id+i))))
+ c(je+j)=
+ * c4*((a(ia+i)+cos72*(a(ib+i)+a(ie+i))-cos36*(a(ic+i)+a(id+i)))
+ * +(sin72*(b(ib+i)-b(ie+i))+sin36*(b(ic+i)-b(id+i))))
+ * -s4*((b(ia+i)+cos72*(b(ib+i)+b(ie+i))-cos36*(b(ic+i)+b(id+i)))
+ * -(sin72*(a(ib+i)-a(ie+i))+sin36*(a(ic+i)-a(id+i))))
+ d(je+j)=
+ * s4*((a(ia+i)+cos72*(a(ib+i)+a(ie+i))-cos36*(a(ic+i)+a(id+i)))
+ * +(sin72*(b(ib+i)-b(ie+i))+sin36*(b(ic+i)-b(id+i))))
+ * +c4*((b(ia+i)+cos72*(b(ib+i)+b(ie+i))-cos36*(b(ic+i)+b(id+i)))
+ * -(sin72*(a(ib+i)-a(ie+i))+sin36*(a(ic+i)-a(id+i))))
+ c(jc+j)=
+ * c2*((a(ia+i)-cos36*(a(ib+i)+a(ie+i))+cos72*(a(ic+i)+a(id+i)))
+ * -(sin36*(b(ib+i)-b(ie+i))-sin72*(b(ic+i)-b(id+i))))
+ * -s2*((b(ia+i)-cos36*(b(ib+i)+b(ie+i))+cos72*(b(ic+i)+b(id+i)))
+ * +(sin36*(a(ib+i)-a(ie+i))-sin72*(a(ic+i)-a(id+i))))
+ d(jc+j)=
+ * s2*((a(ia+i)-cos36*(a(ib+i)+a(ie+i))+cos72*(a(ic+i)+a(id+i)))
+ * -(sin36*(b(ib+i)-b(ie+i))-sin72*(b(ic+i)-b(id+i))))
+ * +c2*((b(ia+i)-cos36*(b(ib+i)+b(ie+i))+cos72*(b(ic+i)+b(id+i)))
+ * +(sin36*(a(ib+i)-a(ie+i))-sin72*(a(ic+i)-a(id+i))))
+ c(jd+j)=
+ * c3*((a(ia+i)-cos36*(a(ib+i)+a(ie+i))+cos72*(a(ic+i)+a(id+i)))
+ * +(sin36*(b(ib+i)-b(ie+i))-sin72*(b(ic+i)-b(id+i))))
+ * -s3*((b(ia+i)-cos36*(b(ib+i)+b(ie+i))+cos72*(b(ic+i)+b(id+i)))
+ * -(sin36*(a(ib+i)-a(ie+i))-sin72*(a(ic+i)-a(id+i))))
+ d(jd+j)=
+ * s3*((a(ia+i)-cos36*(a(ib+i)+a(ie+i))+cos72*(a(ic+i)+a(id+i)))
+ * +(sin36*(b(ib+i)-b(ie+i))-sin72*(b(ic+i)-b(id+i))))
+ * +c3*((b(ia+i)-cos36*(b(ib+i)+b(ie+i))+cos72*(b(ic+i)+b(id+i)))
+ * -(sin36*(a(ib+i)-a(ie+i))-sin72*(a(ic+i)-a(id+i))))
+ i=i+inc3
+ j=j+inc4
+ 145 continue
+ ibase=ibase+inc1
+ jbase=jbase+inc2
+ 150 continue
+ jbase=jbase+jump
+ 160 continue
+ return
+ end
Added: 3D/MAG/trunk/src/wpassm.f
===================================================================
--- 3D/MAG/trunk/src/wpassm.f 2006-06-26 21:27:17 UTC (rev 3892)
+++ 3D/MAG/trunk/src/wpassm.f 2006-06-27 00:20:45 UTC (rev 3893)
@@ -0,0 +1,348 @@
+ subroutine wpassm(a,b,c,d,trigs,inc1,inc2,inc3,inc4,lot,n,ifac,la)
+c
+c called in chebtf and fourtf
+c
+ parameter(mmx=96)
+ dimension a(*),b(*),c(*),d(*),trigs(*)
+ dimension c1(mmx),c2(mmx),c3(mmx),c4(mmx)
+ dimension s1(mmx),s2(mmx),s3(mmx),s4(mmx)
+ dimension iindex(mmx),jindex(mmx)
+ data sin36/0.587785252292473/,cos36/0.809016994374947/,
+ * sin72/0.951056516295154/,cos72/0.309016994374947/,
+ * sin60/0.866025403784437/
+c
+ m=n/ifac
+ if(m.gt.mmx) stop 'wpassm: m>mmx'
+ iink=m*inc1
+ jink=la*inc2
+ jump=(ifac-1)*jink
+ ibase=0
+ jbase=0
+ igo=ifac-1
+ if (igo.gt.4) return
+ go to (10,50,90,130),igo
+c
+c coding for factor 2
+c
+ 10 ia=1
+ ja=1
+ ib=ia+iink
+ jb=ja+jink
+c
+ ims=1
+ if(la.lt.m.and.la.lt.16) go to 25
+ do 20 ijk=1,lot
+ iadd=(ijk-1)*inc3
+ jadd=(ijk-1)*inc4
+ do 15 l=1,la
+ i=(l-1)*inc1+iadd
+ j=(l-1)*inc2+jadd
+ c(ja+j)=a(ia+i)+a(ib+i)
+ d(ja+j)=b(ia+i)+b(ib+i)
+ c(jb+j)=a(ia+i)-a(ib+i)
+ d(jb+j)=b(ia+i)-b(ib+i)
+ 15 continue
+ 20 continue
+c
+ if (la.eq.m) return
+ ims=la+1
+c
+ 25 do 26 im=ims,m
+ kc=(im-1)/la
+ kk=kc*la
+ c1(im)=trigs(2*kk+1)
+ s1(im)=trigs(2*kk+2)
+ iindex(im)=im*inc1
+ jindex(im)=im*inc2+jump*kc
+ 26 continue
+c
+ do 30 ijk=1,lot
+ iadd=(ijk-1)*inc3 - inc1
+ jadd=(ijk-1)*inc4 - inc2
+ do 28 im=ims,m
+ i= iindex(im)+iadd
+ j= jindex(im)+jadd
+ c(ja+j)=a(ia+i)+a(ib+i)
+ d(ja+j)=b(ia+i)+b(ib+i)
+ c(jb+j)=c1(im)*(a(ia+i)-a(ib+i))-s1(im)*(b(ia+i)-b(ib+i))
+ d(jb+j)=s1(im)*(a(ia+i)-a(ib+i))+c1(im)*(b(ia+i)-b(ib+i))
+ 28 continue
+ 30 continue
+ return
+c
+c coding for factor 3
+c
+ 50 ia=1
+ ja=1
+ ib=ia+iink
+ jb=ja+jink
+ ic=ib+iink
+ jc=jb+jink
+c
+ ims=1
+ if(la.lt.m.and.la.lt.16) go to 65
+ do 60 ijk=1,lot
+ iadd=(ijk-1)*inc3
+ jadd=(ijk-1)*inc4
+ do 55 l=1,la
+ i=(l-1)*inc1+iadd
+ j=(l-1)*inc2+jadd
+ c(ja+j)=a(ia+i)+(a(ib+i)+a(ic+i))
+ d(ja+j)=b(ia+i)+(b(ib+i)+b(ic+i))
+ c(jb+j)=(a(ia+i)-0.5*(a(ib+i)+a(ic+i)))-(sin60*(b(ib+i)-b(ic+i)))
+ c(jc+j)=(a(ia+i)-0.5*(a(ib+i)+a(ic+i)))+(sin60*(b(ib+i)-b(ic+i)))
+ d(jb+j)=(b(ia+i)-0.5*(b(ib+i)+b(ic+i)))+(sin60*(a(ib+i)-a(ic+i)))
+ d(jc+j)=(b(ia+i)-0.5*(b(ib+i)+b(ic+i)))-(sin60*(a(ib+i)-a(ic+i)))
+ 55 continue
+ 60 continue
+c
+ if (la.eq.m) return
+ ims=la+1
+c
+ 65 do 66 im=ims,m
+ kc=(im-1)/la
+ kk=kc*la
+ c1(im)=trigs(2*kk+1)
+ s1(im)=trigs(2*kk+2)
+ c2(im)=trigs(4*kk+1)
+ s2(im)=trigs(4*kk+2)
+ iindex(im)=im*inc1
+ jindex(im)=im*inc2+jump*kc
+ 66 continue
+c
+ do 70 ijk=1,lot
+ iadd=(ijk-1)*inc3 - inc1
+ jadd=(ijk-1)*inc4 - inc2
+ do 68 im=ims,m
+ i= iindex(im)+iadd
+ j= jindex(im)+jadd
+ c(ja+j)=a(ia+i)+(a(ib+i)+a(ic+i))
+ d(ja+j)=b(ia+i)+(b(ib+i)+b(ic+i))
+ c(jb+j)=
+ * c1(im)*((a(ia+i)-0.5*(a(ib+i)+a(ic+i)))
+ * -(sin60*(b(ib+i)-b(ic+i))))
+ * -s1(im)*((b(ia+i)-0.5*(b(ib+i)+b(ic+i)))
+ * +(sin60*(a(ib+i)-a(ic+i))))
+ d(jb+j)=
+ * s1(im)*((a(ia+i)-0.5*(a(ib+i)+a(ic+i)))
+ * -(sin60*(b(ib+i)-b(ic+i))))
+ * +c1(im)*((b(ia+i)-0.5*(b(ib+i)+b(ic+i)))
+ * +(sin60*(a(ib+i)-a(ic+i))))
+ c(jc+j)=
+ * c2(im)*((a(ia+i)-0.5*(a(ib+i)+a(ic+i)))
+ * +(sin60*(b(ib+i)-b(ic+i))))
+ * -s2(im)*((b(ia+i)-0.5*(b(ib+i)+b(ic+i)))
+ * -(sin60*(a(ib+i)-a(ic+i))))
+ d(jc+j)=
+ * s2(im)*((a(ia+i)-0.5*(a(ib+i)+a(ic+i)))
+ * +(sin60*(b(ib+i)-b(ic+i))))
+ * +c2(im)*((b(ia+i)-0.5*(b(ib+i)+b(ic+i)))
+ * -(sin60*(a(ib+i)-a(ic+i))))
+ 68 continue
+ 70 continue
+ return
+c
+c coding for factor 4
+c
+ 90 ia=1
+ ja=1
+ ib=ia+iink
+ jb=ja+jink
+ ic=ib+iink
+ jc=jb+jink
+ id=ic+iink
+ jd=jc+jink
+c
+ ims=1
+ if(la.lt.m.and.la.lt.16) go to 105
+ do 100 ijk=1,lot
+ iadd=(ijk-1)*inc3
+ jadd=(ijk-1)*inc4
+ do 95 l=1,la
+ i=(l-1)*inc1+iadd
+ j=(l-1)*inc2+jadd
+ c(ja+j)=(a(ia+i)+a(ic+i))+(a(ib+i)+a(id+i))
+ c(jc+j)=(a(ia+i)+a(ic+i))-(a(ib+i)+a(id+i))
+ d(ja+j)=(b(ia+i)+b(ic+i))+(b(ib+i)+b(id+i))
+ d(jc+j)=(b(ia+i)+b(ic+i))-(b(ib+i)+b(id+i))
+ c(jb+j)=(a(ia+i)-a(ic+i))-(b(ib+i)-b(id+i))
+ c(jd+j)=(a(ia+i)-a(ic+i))+(b(ib+i)-b(id+i))
+ d(jb+j)=(b(ia+i)-b(ic+i))+(a(ib+i)-a(id+i))
+ d(jd+j)=(b(ia+i)-b(ic+i))-(a(ib+i)-a(id+i))
+ 95 continue
+ 100 continue
+
+ if (la.eq.m) return
+ ims=la+1
+c
+ 105 do 106 im=ims,m
+ kc=(im-1)/la
+ kk=kc*la
+ c1(im)=trigs(2*kk+1)
+ s1(im)=trigs(2*kk+2)
+ c2(im)=trigs(4*kk+1)
+ s2(im)=trigs(4*kk+2)
+ c3(im)=trigs(6*kk+1)
+ s3(im)=trigs(6*kk+2)
+ iindex(im)=im*inc1
+ jindex(im)=im*inc2+jump*kc
+ 106 continue
+c
+ do 110 ijk=1,lot
+ iadd=(ijk-1)*inc3 - inc1
+ jadd=(ijk-1)*inc4 - inc2
+ do 108 im=ims,m
+ i= iindex(im)+iadd
+ j= jindex(im)+jadd
+ c(ja+j)=(a(ia+i)+a(ic+i))+(a(ib+i)+a(id+i))
+ d(ja+j)=(b(ia+i)+b(ic+i))+(b(ib+i)+b(id+i))
+ c(jc+j)=
+ * c2(im)*((a(ia+i)+a(ic+i))-(a(ib+i)+a(id+i)))
+ * -s2(im)*((b(ia+i)+b(ic+i))-(b(ib+i)+b(id+i)))
+ d(jc+j)=
+ * s2(im)*((a(ia+i)+a(ic+i))-(a(ib+i)+a(id+i)))
+ * +c2(im)*((b(ia+i)+b(ic+i))-(b(ib+i)+b(id+i)))
+ c(jb+j)=
+ * c1(im)*((a(ia+i)-a(ic+i))-(b(ib+i)-b(id+i)))
+ * -s1(im)*((b(ia+i)-b(ic+i))+(a(ib+i)-a(id+i)))
+ d(jb+j)=
+ * s1(im)*((a(ia+i)-a(ic+i))-(b(ib+i)-b(id+i)))
+ * +c1(im)*((b(ia+i)-b(ic+i))+(a(ib+i)-a(id+i)))
+ c(jd+j)=
+ * c3(im)*((a(ia+i)-a(ic+i))+(b(ib+i)-b(id+i)))
+ * -s3(im)*((b(ia+i)-b(ic+i))-(a(ib+i)-a(id+i)))
+ d(jd+j)=
+ * s3(im)*((a(ia+i)-a(ic+i))+(b(ib+i)-b(id+i)))
+ * +c3(im)*((b(ia+i)-b(ic+i))-(a(ib+i)-a(id+i)))
+ 108 continue
+ 110 continue
+ return
+c
+c coding for factor 5
+c
+ 130 ia=1
+ ja=1
+ ib=ia+iink
+ jb=ja+jink
+ ic=ib+iink
+ jc=jb+jink
+ id=ic+iink
+ jd=jc+jink
+ ie=id+iink
+ je=jd+jink
+c
+ ims=1
+ if(la.lt.m.and.la.lt.16) go to 145
+ do 140 ijk=1,lot
+ iadd=(ijk-1)*inc3
+ jadd=(ijk-1)*inc4
+ do 135 l=1,la
+ i=(l-1)*inc1+iadd
+ j=(l-1)*inc2+jadd
+ c(ja+j)=a(ia+i)+(a(ib+i)+a(ie+i))+(a(ic+i)+a(id+i))
+ d(ja+j)=b(ia+i)+(b(ib+i)+b(ie+i))+(b(ic+i)+b(id+i))
+ c(jb+j)=(a(ia+i)+cos72*(a(ib+i)+a(ie+i))-cos36*(a(ic+i)+a(id+i)))
+ * -(sin72*(b(ib+i)-b(ie+i))+sin36*(b(ic+i)-b(id+i)))
+ c(je+j)=(a(ia+i)+cos72*(a(ib+i)+a(ie+i))-cos36*(a(ic+i)+a(id+i)))
+ * +(sin72*(b(ib+i)-b(ie+i))+sin36*(b(ic+i)-b(id+i)))
+ d(jb+j)=(b(ia+i)+cos72*(b(ib+i)+b(ie+i))-cos36*(b(ic+i)+b(id+i)))
+ * +(sin72*(a(ib+i)-a(ie+i))+sin36*(a(ic+i)-a(id+i)))
+ d(je+j)=(b(ia+i)+cos72*(b(ib+i)+b(ie+i))-cos36*(b(ic+i)+b(id+i)))
+ * -(sin72*(a(ib+i)-a(ie+i))+sin36*(a(ic+i)-a(id+i)))
+ c(jc+j)=(a(ia+i)-cos36*(a(ib+i)+a(ie+i))+cos72*(a(ic+i)+a(id+i)))
+ * -(sin36*(b(ib+i)-b(ie+i))-sin72*(b(ic+i)-b(id+i)))
+ c(jd+j)=(a(ia+i)-cos36*(a(ib+i)+a(ie+i))+cos72*(a(ic+i)+a(id+i)))
+ * +(sin36*(b(ib+i)-b(ie+i))-sin72*(b(ic+i)-b(id+i)))
+ d(jc+j)=(b(ia+i)-cos36*(b(ib+i)+b(ie+i))+cos72*(b(ic+i)+b(id+i)))
+ * +(sin36*(a(ib+i)-a(ie+i))-sin72*(a(ic+i)-a(id+i)))
+ d(jd+j)=(b(ia+i)-cos36*(b(ib+i)+b(ie+i))+cos72*(b(ic+i)+b(id+i)))
+ * -(sin36*(a(ib+i)-a(ie+i))-sin72*(a(ic+i)-a(id+i)))
+ 135 continue
+ 140 continue
+c
+ if (la.eq.m) return
+ ims=la+1
+c
+ 145 do 146 im=ims,m
+ kc=(im-1)/la
+ kk=kc*la
+ c1(im)=trigs(2*kk+1)
+ s1(im)=trigs(2*kk+2)
+ c2(im)=trigs(4*kk+1)
+ s2(im)=trigs(4*kk+2)
+ c3(im)=trigs(6*kk+1)
+ s3(im)=trigs(6*kk+2)
+ c4(im)=trigs(8*kk+1)
+ s4(im)=trigs(8*kk+2)
+ iindex(im)=im*inc1
+ jindex(im)=im*inc2+jump*kc
+ 146 continue
+c
+ do 150 ijk=1,lot
+ iadd=(ijk-1)*inc3 - inc1
+ jadd=(ijk-1)*inc4 - inc2
+ do 148 im=ims,m
+ i= iindex(im)+iadd
+ j= jindex(im)+jadd
+ c(ja+j)=a(ia+i)+(a(ib+i)+a(ie+i))+(a(ic+i)+a(id+i))
+ d(ja+j)=b(ia+i)+(b(ib+i)+b(ie+i))+(b(ic+i)+b(id+i))
+ c(jb+j)=
+ * c1(im)*((a(ia+i)+cos72*(a(ib+i)+a(ie+i))
+ * -cos36*(a(ic+i)+a(id+i)))
+ * -(sin72*(b(ib+i)-b(ie+i))+sin36*(b(ic+i)-b(id+i))))
+ * -s1(im)*((b(ia+i)+cos72*(b(ib+i)+b(ie+i))
+ * -cos36*(b(ic+i)+b(id+i)))
+ * +(sin72*(a(ib+i)-a(ie+i))+sin36*(a(ic+i)-a(id+i))))
+ d(jb+j)=
+ * s1(im)*((a(ia+i)+cos72*(a(ib+i)+a(ie+i))
+ * -cos36*(a(ic+i)+a(id+i)))
+ * -(sin72*(b(ib+i)-b(ie+i))+sin36*(b(ic+i)-b(id+i))))
+ * +c1(im)*((b(ia+i)+cos72*(b(ib+i)+b(ie+i))
+ * -cos36*(b(ic+i)+b(id+i)))
+ * +(sin72*(a(ib+i)-a(ie+i))+sin36*(a(ic+i)-a(id+i))))
+ c(je+j)=
+ * c4(im)*((a(ia+i)+cos72*(a(ib+i)+a(ie+i))
+ * -cos36*(a(ic+i)+a(id+i)))
+ * +(sin72*(b(ib+i)-b(ie+i))+sin36*(b(ic+i)-b(id+i))))
+ * -s4(im)*((b(ia+i)+cos72*(b(ib+i)+b(ie+i))
+ * -cos36*(b(ic+i)+b(id+i)))
+ * -(sin72*(a(ib+i)-a(ie+i))+sin36*(a(ic+i)-a(id+i))))
+ d(je+j)=
+ * s4(im)*((a(ia+i)+cos72*(a(ib+i)+a(ie+i))
+ * -cos36*(a(ic+i)+a(id+i)))
+ * +(sin72*(b(ib+i)-b(ie+i))+sin36*(b(ic+i)-b(id+i))))
+ * +c4(im)*((b(ia+i)+cos72*(b(ib+i)+b(ie+i))
+ * -cos36*(b(ic+i)+b(id+i)))
+ * -(sin72*(a(ib+i)-a(ie+i))+sin36*(a(ic+i)-a(id+i))))
+ c(jc+j)=
+ * c2(im)*((a(ia+i)-cos36*(a(ib+i)+a(ie+i))
+ * +cos72*(a(ic+i)+a(id+i)))
+ * -(sin36*(b(ib+i)-b(ie+i))-sin72*(b(ic+i)-b(id+i))))
+ * -s2(im)*((b(ia+i)-cos36*(b(ib+i)+b(ie+i))
+ * +cos72*(b(ic+i)+b(id+i)))
+ * +(sin36*(a(ib+i)-a(ie+i))-sin72*(a(ic+i)-a(id+i))))
+ d(jc+j)=
+ * s2(im)*((a(ia+i)-cos36*(a(ib+i)+a(ie+i))
+ * +cos72*(a(ic+i)+a(id+i)))
+ * -(sin36*(b(ib+i)-b(ie+i))-sin72*(b(ic+i)-b(id+i))))
+ * +c2(im)*((b(ia+i)-cos36*(b(ib+i)+b(ie+i))
+ * +cos72*(b(ic+i)+b(id+i)))
+ * +(sin36*(a(ib+i)-a(ie+i))-sin72*(a(ic+i)-a(id+i))))
+ c(jd+j)=
+ * c3(im)*((a(ia+i)-cos36*(a(ib+i)+a(ie+i))
+ * +cos72*(a(ic+i)+a(id+i)))
+ * +(sin36*(b(ib+i)-b(ie+i))-sin72*(b(ic+i)-b(id+i))))
+ * -s3(im)*((b(ia+i)-cos36*(b(ib+i)
+ * +b(ie+i))+cos72*(b(ic+i)+b(id+i)))
+ * -(sin36*(a(ib+i)-a(ie+i))-sin72*(a(ic+i)-a(id+i))))
+ d(jd+j)=
+ * s3(im)*((a(ia+i)-cos36*(a(ib+i)+a(ie+i))
+ * +cos72*(a(ic+i)+a(id+i)))
+ * +(sin36*(b(ib+i)-b(ie+i))-sin72*(b(ic+i)-b(id+i))))
+ * +c3(im)*((b(ia+i)-cos36*(b(ib+i)+b(ie+i))
+ * +cos72*(b(ic+i)+b(id+i)))
+ * -(sin36*(a(ib+i)-a(ie+i))-sin72*(a(ic+i)-a(id+i))))
+ 148 continue
+ 150 continue
+ return
+ end
More information about the Cig-commits
mailing list