!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
!  3) partie module "null" pour l'utilisation de trace de geopack
!     qui additione dans tous les cas la partie IGRF interne
!     a la partie externe donnee en argument.
!     Permet le calcul des lignes de force dipolaires ou IGRF.
!
! ----|--------------------------------------------------------------0--
!
      SUBROUTINE exzero(IOPT,PARMOD,PS,X,Y,Z,BX,BY,BZ)
!
      DIMENSION PARMOD(10)

! P.Ro. unused common, just to avoid compilor warning as : 
! "Unused variable parmod declared at..."
  common /useless/ unused

  unused=parmod(1)+PS+X+Y+Z+float(iopt)
!
      BX=0.
      BY=0.
      BZ=0.
!
      RETURN
      END

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
! tsygalib.f:  modeles de champ externe de tsyganenko:
!
! T89c: modele de Tsyganenko 89 revise en 1996
! T87s: modele de Tsyganenko 87 version "short" (ancien exshor)
! T87l: modele de Tsyganenko 89 version "long" (ancien exlong)
!
! pour la partie dipole ou IGRF, prendre la geopacklib, et additionner
! les 2 via la tsauxlib
!
!  P. Robert, CNRS/CETP, Juin 2002
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
!  1) partie Tsyganenko 87
!
!  version Fortran UNIX du modele de Tsyganenko 1987
!  =================================================
!
!  P. Robert, Mai 1994 - revu janvier 95
!                      - revu decembre 96
!
!  Revision importante de juin 2002:
!  --------------------------------
!
! suppression de tout ce qui est champ interne, remplace par
! le module GEOPACKLIB, et conservation des 2 seuls modules
! exshor et exlong, renomme T87s et T87l, avec des arguments
! compatibles avec le modele T89c
!
! Rappel de la version  de juillet 93:
! ===================================
!
!  version dos87
!  -------------
!
!  Tsyganenko 1987 a ete livre initialement en fortran version DOS
!  le directory tsygalib/v_dos87 contient l'image de la disquette DOS
!  sans aucunes modifs.
!
!  version unix87
!  --------------
!
!  Tous les programmes de v_dos87 ont ete recopies dans le directory
!  tsygalib/v_unix87 ou figure ce fichier readme_PR.txt
!  puis adapte par P.R. en fortran UNIX avec uniquement des modifs
!  mineures et correction de petits bugs de la version initiale DOS,
!  en particulier:
!
!  	 -retrait des CTRLM de fin de lignes des fichiers DOS
!  	 -modifs sur les conflits print*, write*,write(6) etc.
!  	  dans certains fichiers des programmes principaux
!  	 -recompilation du tout, creation de la library tsysub.o
!  	  et des executables
!  	 -les conventions DOS de nommages des fichiers ont ete
!  	  converties version UNIX:
!  	       .tous les *.for -> *.f
!  	       .tous les *.obj -> *.o
!  	       .tous les *.exe -> *.exe
!  	       .tsy.bat        ->tsy.bat (lance tsydri.exe)
!
!
!  version ESA 93
!  --------------
!
!  Une autre version UNIX, faite specialement pour l'ESA,
!  a ete faite, et mise dans le directory tsygalib/v_esa.
!  cette version est derivee de la version UNIX et concerne
!  uniquement la bibliotheque tsysub.o qui a ete renomme en
!  tsygalib.o
!  Cette version est deduite de tsysub.f avec  quelques
!  modifications demandees par l'ESA pour eviter des pb sur SUN
!  avec d'eventuelles routines  en C pour interfacage avec ISDAT:
!
!        -remplacement de la routine SUN par SUNPO,
!        -remplacement de la routine EXTERN par EXSHOR
!         (pour short, par analogie avec EXLONG)
!
!  De plus, deux programmes d'exemples (examp1.exe et examp2.exe)
!  ont ete ajoutes et permettent d'illuster l'utilisation
!  de la bibliotheque tsygalib.o
!
!
!  A l'exception de ces 2 subroutines qui ont change de nom, et du
!  fichier test.out qui correspond a testout.dat du package initial,
!  cette bibliotheque tsygalib.o et tous les executables du directory
!  correspond a la documentation papier referencee ci-dessous:
!
!        XX  Document de travail DT/CRPE/1232
!        XX
!        XX  CLUSTER SOFTWARE  TOOLS  PART II
!        XX
!        XX  COMMENTS ON TSYGANENKO 1987 SOFTWARE PACKAGE
!        XX
!        XX  Par Patrick ROBERT  CRPE/TID, Juillet 1993
!
!  C'est a priori la version de reference pour CLUSTER
!
!
!  N.B. modif du 6/12/96:
!  ---------------------
!
!  correction du bug dans RECALC (variabel AL)
!
!
! version champ exterbe seul de juin 2002:
! =======================================
!
!
!*******************************************************************
! Subroutines and functions for Tsyganenko's 1987 magnetic field
! model:
! N.A. Tsyganenko, A.V. Usmanov, V.O. Papitashvili, N.E.
! Papitashvili, and V.A. Popov, Software for computation of the
!   geomagnetic field and related coordinate systems, Academy of
!   Sciences of the USSR, Soviet Geophysical Committee, Moscow, 1987
!
! ----------------- magnetic field components: --------------------
! T87s: GSM components of external magnetic field (Tsyganenko model)
! T87l: 'Long' version of Tsyganenko's model
!*******************************************************************
!
!
      SUBROUTINE T87s(IOPT,PARMOD,PS,X,Y,Z,BX,BY,BZ)
!------------------------------------------------------------------
!  Computes GSM components of the magnetic field of extraterrestrial
!  current systems up to geocentric radial distances about 30 Re .
!  Corresponds to magnetospheric field model (N.A.Tsyganenko, 1986)
!  Based on IMP-A,C,D,E,F,G,H,I,J (years 1966-1980) and HEOS-1,2
!  (1969-1974) satellite merged data set.
!
! 	INPUT:	IOPT	specifies model version, according to
!    			ground disturbance level, as specified below
!    		PS	geodipole tilt angle in radians
!  		X,Y,Z 	GSM coordinates of the point in earth radii
!
!	OUTPUT:	BX,BY,BZ 	GSM components of the external
!    				magnetic field in nanotesla
!
!  IOPT    1     2      3       4      5        6         7      8
!   KP    0,0+  1-,1   1+,2-   2,2+  3-,3,3+   4-,4,4+   >=5-   >=5+
!
!   THE PARAMETER PARMOD(10) IS A DUMMY ARRAY.  IT IS NOT USED IN THIS
!   SUBROUTINE AND IS PROVIDED JUST FOR MAKING IT COMPATIBLE WITH THE
!   NEW VERSION (4/16/96) OF THE GEOPACK SOFTWARE.
!--------------------------------------------------------------------
! jah, pas de save implicit avec ifort sous Linux ni avec g77 sous windows :
      save
      DIMENSION GA1(24),GA2(24),GA3(24),GA4(24),GA5(24),GA6(24),GA7(24), &
      GA8(24),PA(24)
      DIMENSION PARMOD(10)
!
      DATA GA1/1.126,26.66,-.077,-.06102,-.06197,-2.048,.00327,.008473, &
      12.72,-.00867,-.001953,-.3437,-.002903,-.000999,18.41,-270.3, &
      -25.94,5.21,-6.2,2.29,11.96,8.315,44.22,11.15/
      DATA GA2/1.403,29.24,-.0693,-.0864,-.07202,-2.068,.00286,.007438, &
      16.37,-.02705,-.0281,-.604,-.002256,.000152,20.2,-140.1,-29.65, &
      5.62,-5.52,2.02,14.66,8.06,27.76,10.94/
      DATA GA3/1.589,31.07,-.06527,-.07447,-.07632,-2.413,.002719, &
      .01098,16.2,-.02355,-.03475,-.4377,-.002169,-.001383,18.7,-292.6, &
      -35.25,5.29,-5.18,2.21,14.03,7.66,17.56,10.9/
      DATA GA4/1.699,36.28,-.07514,-.1448,-.08049,-2.209,.000919, &
      .01084,17.38,-.03516,-.03886,-1.169,.004239,.000881,21.79,-162., &
      -41.87,5.15,-3.62,2.35,17.26,7.61,17.99,10.74/
      DATA GA5/2.141,41.51,-.1518,-.1857,-.1015,-2.929,.004584,.01589, &
      18.29,-.02514,-.05927,-1.336,.00185,.001066,21.31,-358.8,-47.91, &
      5.13,-3.74,2.07,17.23,6.33,32.51,9.73/
      DATA GA6/2.252,39.35,-.04525,-.2062,-.1491,-3.059,-.000183, &
      .02614,15.48,-.02144,-.06608,-1.855,.006199,-.00013,23.91,-161., &
      -51.48,4.61,-3.32,1.68,15.22,6.68,.6765,8.007/
      DATA GA7/2.773,40.95,.00667,-.133,-.1304,-5.187,.004623,.03651, &
      20.,-.03765,-.09066,.5838,-.01462,-.007189,24.87,-186.1,-74.81, &
      4.57,-4.03,1.7,12.15,6.87,-1.746,8.9/
      DATA GA8/2.919,34.96,2*0.,-.1609,-5.077,2*0.,22.1,-.05915,-.1051, &
      .6321,2*0.,28.11,-330.1,-86.82,4.,-3.,1.73,12.56,5.11,4.,7.866/
      DATA IP,PSI,HPI,FC,RT/100,10.,1.5707963,0.3183099031,30./

! P.Ro. unused common, just to avoid compilor warning as : 
! "Unused variable parmod declared at..."
  common /useless/ unused

  unused=parmod(1)

      IF (IOPT.EQ.IP) GOTO 2
      IP=IOPT
      DO 1 I=1,24
      IF (IP.EQ.1) PA(I)=GA1(I)
      IF (IP.EQ.2) PA(I)=GA2(I)
      IF (IP.EQ.3) PA(I)=GA3(I)
      IF (IP.EQ.4) PA(I)=GA4(I)
      IF (IP.EQ.5) PA(I)=GA5(I)
      IF (IP.EQ.6) PA(I)=GA6(I)
      IF (IP.EQ.7) PA(I)=GA7(I)
      IF (IP.EQ.8) PA(I)=GA8(I)
  1   CONTINUE
      C1=PA(20)**2
      RRC2=PA(18)**2
      DSTR=PA(17)/RRC2*4.
      XN=PA(19)
      RH=PA(22)
      X1=PA(23)
      DY=PA(21)
      DELX=PA(24)
      B0=PA(15)
      B1=PA(16)
      XN21=(XN-X1)**2
  2   IF(ABS(PS-PSI).LT.1.E-6) GOTO 3
      PSI=PS
      SPS=SIN(PS)
      CPS=COS(PS)
      RPS=RH*SPS
!
!   COMPUTATION BEGINS HERE IF PARAMETERS IOPT AND PS REMAINED UNCHANGE,
!   AFTER THE PRECEDING CALL OF THIS SUBROUTINE
!
  3   ZS=Z-RPS
      ZP=Z-RT
      ZM=Z+RT
      FY=FC/(1.+(Y/DY)**2)
      XNX=XN-X
      XNX2=XNX**2
      XC1=X-X1
      XC12=XC1**2
      B20=ZS**2+C1
      B2P=ZP**2+C1
      B2M=ZM**2+C1
      B=SQRT(B20)
      BP=SQRT(B2P)
      BM=SQRT(B2M)
      XA1=XC12+B20
      XAP1=XC12+B2P
      XAM1=XC12+B2M
      XNA=XNX2+B20
      XNAP=XNX2+B2P
      XNAM=XNX2+B2M
      XLN1=ALOG(XN21/XNA)
      XLNP1=ALOG(XN21/XNAP)
      XLNM1=ALOG(XN21/XNAM)
      ALN=0.25*(XLNP1+XLNM1-2.*XLN1)
      S0=(ATAN(XNX/B)+HPI)/B
      S0P=(ATAN(XNX/BP)+HPI)/BP
      S0M=(ATAN(XNX/BM)+HPI)/BM
      S1=(XLN1*.5+XC1*S0)/XA1
      S1P=(XLNP1*.5+XC1*S0P)/XAP1
      S1M=(XLNM1*.5+XC1*S0M)/XAM1
      G1=(B20*S0-0.5*XC1*XLN1)/XA1
      G1P=(B2P*S0P-0.5*XC1*XLNP1)/XAP1
      G1M=(B2M*S0M-0.5*XC1*XLNM1)/XAM1
      BX=FY*(B0*(ZS*S0-0.5*(ZP*S0P+ZM*S0M)) &
       +B1*(ZS*S1-0.5*(ZP*S1P+ZM*S1M)))
      BY=0.
      BZ=FY*(B0*ALN+B1*(G1-0.5*(G1P+G1M)))
!
!    CALCULATION OF THE MAGNETOTAIL CURRENT CONTRIBUTION IS FINISHED
!
      EX=EXP(X/DELX)
      Y2=Y**2
      Z2=Z**2
      YZ=Y*Z
      BX=BX+EX*(CPS*PA(1)*Z+SPS*(PA(2)+PA(3)*YZ+PA(4)*Z2))
      BY=EX*(CPS*PA(5)*YZ+SPS*Y*(PA(6)+PA(7)*Y2+PA(8)*Z2))
      BZ=BZ+EX*(CPS*(PA(9)+PA(10)*Y2+PA(11)*Z2)+SPS*Z*(PA(12) &
      +PA(13)*Y2+PA(14)*Z2))
!
!   DCF AND FAC CONTRIBUTION HAS BEEN ADDED TO BX,BY, AND BZ
!
      XSM=X*CPS-Z*SPS
      ZSM=X*SPS+Z*CPS
      Z2=ZSM**2
      RR2=XSM**2+Y**2
! jah, foresys : Result of assignment to RR is not used
! jah,      RR=SQRT(RR2)
      ZN=SQRT((RR2+Z2)/RRC2+4.)**5
      BRSM=DSTR*3.*ZSM/ZN
      BZSM=DSTR*(2.*Z2-RR2+8.*RRC2)/ZN
      BY1=BRSM*Y
      BXSM=BRSM*XSM
      BX=BX+BXSM*CPS+BZSM*SPS
      BZ=BZ-BXSM*SPS+BZSM*CPS
      BY=BY+BY1
!
!   RING CURRENT FIELD HAS BEEN TAKEN INTO ACCOUNT
!
      RETURN
      END
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
      SUBROUTINE T87l(IOPT,PARMOD,PS,X,Y,Z,BX,BY,BZ)
!-------------------------------------------------------------------
!  'LONG' version of the magnetospheric magnetic field model.
!  Computes GSM components of the magnetic field of extraterrestrial
!  current systems up to geocentric radial distances about 70 Re .
!  Corresponds to magnetospheric field model (N.A.Tsyganenko, 1986)
!  based on IMP-A,C,D,E,F,G,H,I,J (years 1966-1974) and HEOS-1,2
!  (1969-1974) satellite merged data set.
!
! 	INPUT:	IOPT	specifies model version, according to
!    			ground disturbance level, as specified below
!    		PS	geodipole tilt angle in radians
!  		X,Y,Z 	GSM coordinates of the point in earth radii
!
!	OUTPUT:	BX,BY,BZ 	GSM components of the external
!    				magnetic field in nanotesla
!
!  IOPT     1      2         3        4         5        6
!   KP    0,0+  1-,1,1+   2-,2,2+  3-,3,3+   4-,4,4+   >=5-
!
!   THE PARAMETER PARMOD(10) IS A DUMMY ARRAY.  IT IS NOT USED IN THIS
!   SUBROUTINE AND IS PROVIDED JUST FOR MAKING IT COMPATIBLE WITH THE
!   NEW VERSION (4/16/96) OF THE GEOPACK SOFTWARE.
!--------------------------------------------------------------------
! jah, pas de save implicit avec ifort sous Linux ni avec g77 sous windows :
      save
      DIMENSION GA1(32),GA2(32),GA3(32),GA4(32),GA5(32),GA6(32),PA(32)
      DIMENSION PARMOD(10)
!
      DATA GA1/-.09673,-10.63,1.21,34.57,-.04502,-.06553,-.02952,.3852, &
      -.03665,-2.084,.001795,.00638,-23.49,.06082,.01642,-.02137,32.21, &
      -.04373,-.02311,-.2832,-.002303,-.000631,-6.397,-967.,-8650., &
      -20.55,5.18,-2.796,2.715,13.58,8.038,29.21/
      DATA GA2/-.485,-12.84,1.856,40.06,-.0294,-.09071,-.02993,.5465, &
      -.04928,-2.453,.001587,.007402,-29.41,.08101,.02322,-.1091,40.75, &
      -.07995,-.03859,-.2755,-.002759,-.000408,-6.189,-957.8,-7246., &
      -25.51,5.207,-4.184,2.641,16.56,7.795,29.36/
      DATA GA3/-1.132,-18.05,2.625,48.55,-.004868,-.1087,-.03824,.8514, &
      -.0522,-2.881,-.000295,.009055,-29.48,.06394,.03864,-.2288,41.77, &
      -.05849,-.06443,-.4683,.001222,-.000519,-3.696,-991.1,-6955., &
      -31.43,4.878,-3.151,3.277,19.19,7.248,28.99/
      DATA GA4/-1.003,-16.98,3.14,52.81,-.08625,-.1478,-.03501,.55, &
      -.07778,-2.97,.002086,.01275,-26.79,.06328,.03622,.08345,39.72, &
      -.06009,-.07825,-.9698,.000178,-.000573,-.9328,-872.5,-5851., &
      -39.68,4.902,-3.848,2.79,20.91,6.193,26.81/
      DATA GA5/-1.539,-14.29,3.479,53.36,-.004201,-.2043,-.03932,.6409, &
      -.1058,-3.221,-.00114,-.02166,-30.43,.04049,.05464,.008884,42., &
      -.01035,-.1053,-1.63,.003802,-.001029,4.204,-665.6,-1011.,-43.49, &
      4.514,-2.948,2.99,21.59,6.005,22./
      DATA GA6/-2.581,-7.726,5.045,53.31,.02262,-.1972,-.01981,.428, &
      -.1055,-5.075,.002762,.03277,-27.35,.04986,.06119,-.1211,47.48, &
      -.0502,-.1477,.838,-.01008,-.0057,9.231,-674.3,-900.,-74.43, &
      4.658,-3.245,3.39,21.8,5.62,25.17/
      DATA IP,PSI,HPI,FC,RT,X1,X2/100,10.,1.5707963,0.3183099031, &
      30.,4.,5./


! P.Ro. unused common, just to avoid compilor warning as : 
! "Unused variable parmod declared at..."
  common /useless/ unused

  unused=parmod(1)

      IF (IOPT.EQ.IP) GOTO 2
      IP=IOPT
      DO 1 I=1,32
      IF (IP.EQ.1) PA(I)=GA1(I)
      IF (IP.EQ.2) PA(I)=GA2(I)
      IF (IP.EQ.3) PA(I)=GA3(I)
      IF (IP.EQ.4) PA(I)=GA4(I)
      IF (IP.EQ.5) PA(I)=GA5(I)
      IF (IP.EQ.6) PA(I)=GA6(I)
  1   CONTINUE
      C1=PA(29)**2
      RRC2=PA(27)**2
!     TYPE *,GA1
!     TYPE *,PA
!     TYPE *,RRC2,PA(27)
      DSTR=PA(26)/RRC2*4.
      XN=PA(28)
      RH=PA(31)
      DY=PA(30)
      DELX=PA(32)
      B0=PA(23)
      B1=PA(24)
      B2=PA(25)
      XN21=(XN-X1)**2
      XN2=XN-X2
      XNR=1./XN2
      XN22=XN2**2
      ADLN=ALOG(XN22/XN21)
  2   IF(ABS(PS-PSI).LT.1.E-6) GOTO 3
      PSI=PS
      SPS=SIN(PS)
      CPS=COS(PS)
      RPS=RH*SPS
!
!   COMPUTATION BEGINS HERE IF PARAMETERS IOPT AND PS REMAINED UNCHANGED
!   AFTER THE PRECEDING CALL OF THIS SUBROUTINE
!
  3   ZS=Z-RPS
      ZP=Z-RT
      ZM=Z+RT
      FY=FC/(1.+(Y/DY)**2)
      XNX=XN-X
      XNX2=XNX**2
      XC1=X-X1
      XC2=X-X2
      XC22=XC2**2
      XR2=XC2*XNR
      XC12=XC1**2
      B20=ZS**2+C1
      B2P=ZP**2+C1
      B2M=ZM**2+C1
      B=SQRT(B20)
      BP=SQRT(B2P)
      BM=SQRT(B2M)
      XA1=XC12+B20
      XAP1=XC12+B2P
      XAM1=XC12+B2M
      XA2=1./(XC22+B20)
      XAP2=1./(XC22+B2P)
      XAM2=1./(XC22+B2M)
      XNA=XNX2+B20
      XNAP=XNX2+B2P
      XNAM=XNX2+B2M
      F=B20-XC22
      FP=B2P-XC22
      FM=B2M-XC22
      XLN1=ALOG(XN21/XNA)
      XLNP1=ALOG(XN21/XNAP)
      XLNM1=ALOG(XN21/XNAM)
      XLN2=XLN1+ADLN
      XLNP2=XLNP1+ADLN
      XLNM2=XLNM1+ADLN
      ALN=0.25*(XLNP1+XLNM1-2.*XLN1)
      S0=(ATAN(XNX/B)+HPI)/B
      S0P=(ATAN(XNX/BP)+HPI)/BP
      S0M=(ATAN(XNX/BM)+HPI)/BM
      S1=(XLN1*.5+XC1*S0)/XA1
      S1P=(XLNP1*.5+XC1*S0P)/XAP1
      S1M=(XLNM1*.5+XC1*S0M)/XAM1
      S2=(XC2*XA2*XLN2-XNR-F*XA2*S0)*XA2
      S2P=(XC2*XAP2*XLNP2-XNR-FP*XAP2*S0P)*XAP2
      S2M=(XC2*XAM2*XLNM2-XNR-FM*XAM2*S0M)*XAM2
      G1=(B20*S0-0.5*XC1*XLN1)/XA1
      G1P=(B2P*S0P-0.5*XC1*XLNP1)/XAP1
      G1M=(B2M*S0M-0.5*XC1*XLNM1)/XAM1
      G2=((0.5*F*XLN2+2.*S0*B20*XC2)*XA2+XR2)*XA2
      G2P=((0.5*FP*XLNP2+2.*S0P*B2P*XC2)*XAP2+XR2)*XAP2
      G2M=((0.5*FM*XLNM2+2.*S0M*B2M*XC2)*XAM2+XR2)*XAM2
      BX=FY*(B0*(ZS*S0-0.5*(ZP*S0P+ZM*S0M)) &
       +B1*(ZS*S1-0.5*(ZP*S1P+ZM*S1M))+B2*(ZS*S2-0.5*(ZP*S2P+ZM*S2M)))
      BY=0.
      BZ=FY*(B0*ALN+B1*(G1-0.5*(G1P+G1M))+B2*(G2-0.5*(G2P+G2M)))
!
!    CALCULATION OF THE MAGNETOTAIL CURRENT CONTRIBUTION IS FINISHED
!
      EX1=EXP(X/DELX)
      EX2=EX1**2
      Y2=Y**2
      Z2=Z**2
      YZ=Y*Z
      BX=BX+(EX1*PA(1)+EX2*PA(3))*Z*CPS+(EX1*PA(2)+EX2*(PA(4)+PA(5)* &
      Y2+PA(6)*Z2))*SPS
      BY=(EX1*PA(7)+EX2*PA(9))*YZ*CPS+(EX1*PA(8)+EX2*(PA(10)+PA(11)* &
      Y2+PA(12)*Z2))*Y*SPS
      BZ=BZ+(EX1*(PA(13)+PA(14)*Y2+PA(15)*Z2)+EX2*(PA(17)+PA(18)*Y2+ &
      PA(19)*Z2))*CPS+(EX1*PA(16)+EX2*(PA(20)+PA(21)*Y2+PA(22)*Z2))* &
      Z*SPS
!
!   DCF AND FAC CONTRIBUTION HAS BEEN ADDED TO BX,BY, AND BZ
!
      XSM=X*CPS-Z*SPS
      ZSM=X*SPS+Z*CPS
      Z2=ZSM**2
      RR2=XSM**2+Y**2
! jah, foresys : Result of assignment to RR is not used
! jah,      RR=SQRT(RR2)
      ZN=SQRT((RR2+Z2)/RRC2+4.)**5
      BRSM=DSTR*3.*ZSM/ZN
      BZSM=DSTR*(2.*Z2-RR2+8.*RRC2)/ZN
      BY1=BRSM*Y
      BXSM=BRSM*XSM
      BX=BX+BXSM*CPS+BZSM*SPS
      BZ=BZ-BXSM*SPS+BZSM*CPS
      BY=BY+BY1
!
!   RING CURRENT FIELD HAS BEEN TAKEN INTO ACCOUNT
!
      RETURN
      END
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

!
!     Debut du modele T89C, fichier T89c.txt, telecharger le 17/11/05.
!
!
      SUBROUTINE T89C(IOPT,PARMOD,PS,X,Y,Z,BX,BY,BZ)
!
!   COMPUTES GSM COMPONENTS OF THE MAGNETIC FIELD PRODUCED BY EXTRA-
!   TERRESTRIAL CURRENT SYSTEMS IN THE GEOMAGNETOSPHERE. THE MODEL IS
!   VALID UP TO GEOCENTRIC DISTANCES OF 70 RE AND IS BASED ON THE MER-
!   GED IMP-A,C,D,E,F,G,H,I,J (1966-1974), HEOS-1 AND -2 (1969-1974),
!   AND ISEE-1 AND -2  SPACECRAFT DATA SET.
!
!   THIS IS A MODIFIED VERSION (T89c), WHICH REPLACED THE ORIGINAL ONE
!     IN 1992 AND DIFFERS FROM IT IN THE FOLLOWING:
!
!   (1)  ISEE-1,2 DATA WERE ADDED TO THE ORIGINAL IMP-HEOS DATASET
!   (2)  TWO TERMS WERE ADDED TO THE ORIGINAL TAIL FIELD MODES, ALLOWING
!          A MODULATION OF THE CURRENT BY THE GEODIPOLE TILT ANGLE
!
!
!  REFERENCE FOR THE ORIGINAL MODEL: N.A. TSYGANENKO, A MAGNETOSPHERIC MAGNETIC
!       FIELD MODEL WITH A WARPED TAIL CURRENT SHEET: PLANET.SPACE SCI., V.37,
!         PP.5-20, 1989.
!
!----INPUT PARAMETERS: IOPT - SPECIFIES THE GROUND DISTURBANCE LEVEL:
!
!   IOPT= 1       2        3        4        5        6      7
!                  CORRESPOND TO:
!    KP= 0,0+  1-,1,1+  2-,2,2+  3-,3,3+  4-,4,4+  5-,5,5+  > =6-
!
!    PS - GEODIPOLE TILT ANGLE IN RADIANS
!    X, Y, Z  - GSM COORDINATES OF THE POINT IN EARTH RADII
!
!----OUTPUT PARAMETERS: BX,BY,BZ - GSM COMPONENTS OF THE MODEL MAGNETIC
!                        FIELD IN NANOTESLAS
!
!   THE PARAMETER PARMOD(10) IS A DUMMY ARRAY.  IT IS NOT USED IN THIS
!        SUBROUTINE AND IS PROVIDED JUST FOR MAKING IT COMPATIBLE WITH THE
!           NEW VERSION (4/16/96) OF THE GEOPACK SOFTWARE.
!
!   THIS RELEASE OF T89C IS DATED  FEB 12, 1996;
!--------------------------------------------------------------------------
!
!
!              AUTHOR:     NIKOLAI A. TSYGANENKO
!                          HSTX CORP./NASA GSFC
!
! jah, pas de save implicit avec ifort sous Linux ni avec g77 sous windows :
      save
       DIMENSION XI(4),F(3),DER(3,30),PARAM(30,7),A(30),PARMOD(10)
       DOUBLE PRECISION F,DER
        DATA PARAM/-116.53,-10719.,42.375,59.753,-11363.,1.7844,30.268, &
       -0.35372E-01,-0.66832E-01,0.16456E-01,-1.3024,0.16529E-02, &
       0.20293E-02,20.289,-0.25203E-01,224.91,-9234.8,22.788,7.8813, &
       1.8362,-0.27228,8.8184,2.8714,14.468,32.177,0.01,0.0, &
       7.0459,4.0,20.0,-55.553,-13198.,60.647,61.072,-16064., &
       2.2534,34.407,-0.38887E-01,-0.94571E-01,0.27154E-01,-1.3901, &
       0.13460E-02,0.13238E-02,23.005,-0.30565E-01,55.047,-3875.7, &
       20.178,7.9693,1.4575,0.89471,9.4039,3.5215,14.474,36.555, &
       0.01,0.0,7.0787,4.0,20.0,-101.34,-13480.,111.35,12.386,-24699., &
       2.6459,38.948,-0.34080E-01,-0.12404,0.29702E-01,-1.4052, &
       0.12103E-02,0.16381E-02,24.49,-0.37705E-01,-298.32,4400.9,18.692, &
       7.9064,1.3047,2.4541,9.7012,7.1624,14.288,33.822,0.01,0.0,6.7442, &
       4.0,20.0,-181.69,-12320.,173.79,-96.664,-39051.,3.2633,44.968, &
       -0.46377E-01,-0.16686,0.048298,-1.5473,0.10277E-02,0.31632E-02, &
       27.341,-0.50655E-01,-514.10,12482.,16.257,8.5834,1.0194,3.6148, &
       8.6042,5.5057,13.778,32.373,0.01,0.0,7.3195,4.0,20.0,-436.54, &
       -9001.0,323.66,-410.08,-50340.,3.9932,58.524,-0.38519E-01, &
       -0.26822,0.74528E-01,-1.4268,-0.10985E-02,0.96613E-02,27.557, &
       -0.56522E-01,-867.03,20652.,14.101,8.3501,0.72996,3.8149,9.2908, &
        6.4674,13.729,28.353,0.01,0.0,7.4237,4.0,20.0,-707.77,-4471.9, &
       432.81,-435.51,-60400.,4.6229,68.178,-0.88245E-01,-0.21002, &
       0.11846,-2.6711,0.22305E-02,0.10910E-01,27.547,-0.54080E-01, &
       -424.23,1100.2,13.954,7.5337,0.89714,3.7813,8.2945,5.174,14.213, &
       25.237,0.01,0.0,7.0037,4.0,20.0,-1190.4,2749.9,742.56,-1110.3, &
       -77193.,7.6727,102.05,-0.96015E-01,-0.74507,0.11214,-1.3614, &
       0.15157E-02,0.22283E-01,23.164,-0.74146E-01,-2219.1,48253., &
       12.714,7.6777,0.57138,2.9633,9.3909,9.7263,11.123,21.558,0.01, &
       0.0,4.4518,4.0,20.0/

        DATA IOP/10/

! P.Ro. unused common, just to avoid compilor warning as : 
! "Unused variable parmod declared at..."
  common /useless/ unused

  unused=parmod(1)
!
         IF (IOP.NE.IOPT) THEN
!
            ID=1
            IOP=IOPT
            DO 1 I=1,30
   1        A(I)=PARAM(I,IOPT)
!
         ENDIF
!
        XI(1)=X
        XI(2)=Y
        XI(3)=Z
        XI(4)=PS
         CALL T89(ID,A,XI,F,DER)
! jah, foresys : Result of assignment to ID is not used
! jah,          IF (ID.EQ.1) ID=2
! jah, foresys : Precision loss in assignment from double to real
! jah,        BX=F(1)
        BX=sngl(F(1))
! jah, foresys : Precision loss in assignment from double to real
! jah,        BY=F(2)
        BY=sngl(F(2))
! jah, foresys : Precision loss in assignment from double to real
! jah, BZ=F(3)
        BZ=sngl(F(3))
        RETURN
       END

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
          SUBROUTINE  T89 (ID, A, XI, F, DER)
!
!        ***  N.A. Tsyganenko ***  8-10.12.1991  ***
!
!      Calculates dependent model variables and their deriva-
!  tives for given independent variables and model parame-
!  ters.  Specifies model functions with free parameters which
!  must be determined by means of least squares fits (RMS
!  minimization procedure).
!
!      Description of parameters:
!
!  ID  - number of the data point in a set (initial assignments are performed
!        only for ID=1, saving thus CPU time)
!  A   - input vector containing model parameters;
!  XI  - input vector containing independent variables;
!  F   - output double precision vector containing
!        calculated values of dependent variables;
!  DER   - output double precision vector containing
!        calculated values for derivatives of dependent
!        variables with respect to model parameters;
!
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!
!      T89 represents external magnetospheric magnetic field
!  in Cartesian SOLAR MAGNETOSPHERIC coordinates (Tsyganenko N.A.,
!  Planet. Space Sci., 1989, v.37, p.5-20; the "T89 model" with the warped
!  tail current sheet) + A MODIFICATION ADDED IN APRIL 1992 (SEE BELOW)
!
!      Model formulas for the magnetic field components contain in total
!  30 free parameters (17 linear and 13 nonlinear parameters).
!      First 2 independent linear parameters A(1)-A(2) correspond to contribu-
!  tion from the tail current system, then follow A(3) and A(4) which are the
!  amplitudes of symmetric and antisymmetric terms in the contribution from
!  the closure currents; A(5) is the ring current amplitude. Then follow the
! coefficients A(6)-A(15) which define Chapman-Ferraro+Birkeland current field.
!    The coefficients c16-c19  (see Formula 20 in the original paper),
!   due to DivB=0 condition, are expressed through A(6)-A(15) and hence are not
!    independent ones.
!  A(16) AND A(17) CORRESPOND TO THE TERMS WHICH YIELD THE TILT ANGLE DEPEN-
!    DENCE OF THE TAIL CURRENT INTENSITY (ADDED ON APRIL 9, 1992)
!
!      Nonlinear parameters:
!
!    A(18) : DX - Characteristic scale of the Chapman-Ferraro field along the
!        X-axis
!    A(19) : ADR (aRC) - Characteristic radius of the ring current
!    A(20) : D0 - Basic half-thickness of the tail current sheet
!    A(21) : DD (GamRC)- defines rate of thickening of the ring current, as
!             we go from night- to dayside
!    A(22) : Rc - an analog of "hinging distance" entering formula (11)
!    A(23) : G - amplitude of tail current warping in the Y-direction
!    A(24) : aT - Characteristic radius of the tail current
!    A(25) : Dy - characteristic scale distance in the Y direction entering
!                 in W(x,y) in (13)
!    A(26) : Delta - defines the rate of thickening of the tail current sheet
!                 in the Y-direction (in T89 it was fixed at 0.01)
!    A(27) : Q - this parameter was fixed at 0 in the final version of T89;
!              initially it was introduced for making Dy to depend on X
!    A(28) : Sx (Xo) - enters in W(x,y) ; see (13)
!    A(29) : Gam (GamT) - enters in DT in (13) and defines rate of tail sheet
!              thickening on going from night to dayside; in T89 fixed at 4.0
!    A(30) : Dyc - the Dy parameter for closure current system; in T89 fixed
!               at 20.0
!  - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!
       IMPLICIT  REAL * 8  (A - H, O - Z)
!
         REAL  A(30), XI(4)
!
       DIMENSION  F(3), DER(3,30)
!
         INTEGER  ID, I, L

      save
! jah, foresys : Local variable RPI not used
! jah,         DATA A02,XLW2,YN,RPI,RT/25.D0,170.D0,30.D0,0.31830989D0,30.D0/
         DATA A02,XLW2,RT/25.D0,170.D0,30.D0/
         DATA XD,XLD2/0.D0,40.D0/
!
!   The last four quantities define variation of tail sheet thickness along X
!
      DATA SXC,XLWC2/4.D0,50.D0/
!
!   The two quantities belong to the function WC which confines tail closure
!    current in X- and Y- direction
!
! jah, foresys : Local variable DXL not used
! jah,      DATA DXL/20.D0/
!
!
         IF (ID.NE.1)  GOTO  3
         DO  2  I = 1, 30
           DO  1  L = 1, 3
  1            DER(L,I) = 0.0D0
  2        CONTINUE
!
       DYC=dble(A(30))
       DYC2=DYC**2
       DX=dble(A(18))
       HA02=0.5D0*A02
! jah, foresys : Result of assignment to RDX2M is not used
! jah,       RDX2M=-1.D0/DX**2
! jah, foresys : Result of assignment to RDX2 is not used
! jah,       RDX2=-RDX2M
       RDYC2=1.D0/DYC2
       HLWC2M=-0.5D0*XLWC2
       DRDYC2=-2.D0*RDYC2
! jah, foresys : Result of assignment to DRDYC3 is not used
! jah,       DRDYC3=2.D0*RDYC2*DSQRT(RDYC2)
       HXLW2M=-0.5D0*XLW2
       ADR=dble(A(19))
       D0=dble(A(20))
       DD=dble(A(21))
       RC=dble(A(22))
       G=dble(A(23))
       AT=dble(A(24))
       DT=D0
       DEL=dble(A(26))
       P=dble(A(25))
       Q=dble(A(27))
       SX=dble(A(28))
       GAM=dble(A(29))
       HXLD2M=-0.5D0*XLD2
       ADSL=0.D0
! jah, foresys : Result of assignment to XGHS is not used
! jah,       XGHS=0.D0
! jah, foresys : Result of assignment to H is not used
! jah,       H=0.D0
! jah, foresys : Result of assignment to HS is not used
! jah,       HS=0.D0
! jah, foresys : Result of assignment to GAMH is not used
! jah,       GAMH=0.D0
       W1=-0.5D0/DX
       DBLDEL=2.D0*DEL
       W2=W1*2.D0
       W4=-1.D0/3.D0
       W3=W4/DX
       W5=-0.5D0
       W6=-3.D0
       AK1=dble(A(1))
       AK2=dble(A(2))
       AK3=dble(A(3))
       AK4=dble(A(4))
       AK5=dble(A(5))
       AK6=dble(A(6))
       AK7=dble(A(7))
       AK8=dble(A(8))
       AK9=dble(A(9))
       AK10=dble(A(10))
       AK11=dble(A(11))
       AK12=dble(A(12))
       AK13=dble(A(13))
       AK14=dble(A(14))
       AK15=dble(A(15))
       AK16=dble(A(16))
       AK17=dble(A(17))
       SXA=0.D0
       SYA=0.D0
       SZA=0.D0
       AK610=AK6*W1+AK10*W5
       AK711=AK7*W2-AK11
       AK812=AK8*W2+AK12*W6
       AK913=AK9*W3+AK13*W4
! jah, foresys : Result of assignment to RDXL is not used
! jah,       RDXL=1.D0/DXL
! jah, foresys : Result of assignment to HRDXL is not used
! jah,       HRDXL=0.5D0*RDXL
! jah, foresys : Result of assignment to A6H is not used
! jah,       A6H=AK6*0.5D0
! jah, foresys : Result of assignment to A9T is not used
! jah,       A9T=AK9/3.D0
! jah, foresys : Result of assignment to YNP is not used
! jah,       YNP=RPI/YN*0.5D0
! jah, foresys : Result of assignment to YND is not used
! jah,       YND=2.D0*YN
!
  3      CONTINUE
!
         X  = dble(XI(1))
         Y  = dble(XI(2))
         Z  = dble(XI(3))
         TILT=dble(XI(4))
         TLT2=TILT**2
         SPS = DSIN(TILT)
         CPS = DSQRT (1.0D0 - SPS ** 2)
!
       X2=X*X
       Y2=Y*Y
       Z2=Z*Z
       TPS=SPS/CPS
       HTP=TPS*0.5D0
! jah, foresys : Result of assignment to GSP is not used
! jah,       GSP=G*SPS
       XSM=X*CPS-Z*SPS
       ZSM=X*SPS+Z*CPS
!
!   CALCULATE THE FUNCTION ZS DEFINING THE SHAPE OF THE TAIL CURRENT SHEET
!    AND ITS SPATIAL DERIVATIVES:
!
       XRC=XSM+RC
       XRC16=XRC**2+16.D0
       SXRC=DSQRT(XRC16)
       Y4=Y2*Y2
       Y410=Y4+1.D4
       SY4=SPS/Y410
       GSY4=G*SY4
       ZS1=HTP*(XRC-SXRC)
       DZSX=-ZS1/SXRC
       ZS=ZS1-GSY4*Y4
       D2ZSGY=-SY4/Y410*4.D4*Y2*Y
       DZSY=G*D2ZSGY
!
!   CALCULATE THE COMPONENTS OF THE RING CURRENT CONTRIBUTION:
!
       XSM2=XSM**2
       DSQT=DSQRT(XSM2+A02)
       FA0=0.5D0*(1.D0+XSM/DSQT)
       DDR=D0+DD*FA0
       DFA0=HA02/DSQT**3
       ZR=ZSM-ZS
       TR=DSQRT(ZR**2+DDR**2)
       RTR=1.D0/TR
       RO2=XSM2+Y2
       ADRT=ADR+TR
       ADRT2=ADRT**2
       FK=1.D0/(ADRT2+RO2)
       DSFC=DSQRT(FK)
       FC=FK**2*DSFC
       FACXY=3.0D0*ADRT*FC*RTR
       XZR=XSM*ZR
       YZR=Y*ZR
       DBXDP=FACXY*XZR
       DER(2,5)=FACXY*YZR
       XZYZ=XSM*DZSX+Y*DZSY
       FAQ=ZR*XZYZ-DDR*DD*DFA0*XSM
       DBZDP=FC*(2.D0*ADRT2-RO2)+FACXY*FAQ
       DER(1,5)=DBXDP*CPS+DBZDP*SPS
       DER(3,5)=DBZDP*CPS-DBXDP*SPS
!
!  CALCULATE THE TAIL CURRENT SHEET CONTRIBUTION:
!
       DELY2=DEL*Y2
       D=DT+DELY2
       IF (DABS(GAM).LT.1.D-6) GOTO 8
       XXD=XSM-XD
       RQD=1.D0/(XXD**2+XLD2)
       RQDS=DSQRT(RQD)
       H=0.5D0*(1.D0+XXD*RQDS)
       HS=-HXLD2M*RQD*RQDS
       GAMH=GAM*H
       D=D+GAMH
       XGHS=XSM*GAM*HS
       ADSL=-D*XGHS
   8   D2=D**2
       T=DSQRT(ZR**2+D2)
       XSMX=XSM-SX
       RDSQ2=1.D0/(XSMX**2+XLW2)
       RDSQ=DSQRT(RDSQ2)
       V=0.5D0*(1.D0-XSMX*RDSQ)
       DVX=HXLW2M*RDSQ*RDSQ2
       OM=DSQRT(DSQRT(XSM2+16.D0)-XSM)
       OMS=-OM/(OM*OM+XSM)*0.5D0
       RDY=1.D0/(P+Q*OM)
       OMSV=OMS*V
       RDY2=RDY**2
       FY=1.D0/(1.D0+Y2*RDY2)
       W=V*FY
       YFY1=2.D0*FY*Y2*RDY2
       FYPR=YFY1*RDY
       FYDY=FYPR*FY
       DWX=DVX*FY+FYDY*Q*OMSV
       YDWY=-V*YFY1*FY
       DDY=DBLDEL*Y
       ATT=AT+T
       S1=DSQRT(ATT**2+RO2)
       F5=1.D0/S1
       F7=1.D0/(S1+ATT)
       F1=F5*F7
       F3=F5**3
       F9=ATT*F3
       FS=ZR*XZYZ-D*Y*DDY+ADSL
       XDWX=XSM*DWX+YDWY
       RTT=1.D0/T
       WT=W*RTT
       BRRZ1=WT*F1
       BRRZ2=WT*F3
       DBXC1=BRRZ1*XZR
       DBXC2=BRRZ2*XZR
       DER(2,1)=BRRZ1*YZR
       DER(2,2)=BRRZ2*YZR
          DER(2,16)=DER(2,1)*TLT2
          DER(2,17)=DER(2,2)*TLT2
       WTFS=WT*FS
       DBZC1=W*F5+XDWX*F7+WTFS*F1
       DBZC2=W*F9+XDWX*F1+WTFS*F3
       DER(1,1)=DBXC1*CPS+DBZC1*SPS
       DER(1,2)=DBXC2*CPS+DBZC2*SPS
       DER(3,1)=DBZC1*CPS-DBXC1*SPS
       DER(3,2)=DBZC2*CPS-DBXC2*SPS
          DER(1,16)=DER(1,1)*TLT2
          DER(1,17)=DER(1,2)*TLT2
          DER(3,16)=DER(3,1)*TLT2
          DER(3,17)=DER(3,2)*TLT2
!
!  CALCULATE CONTRIBUTION FROM THE CLOSURE CURRENTS
!
       ZPL=Z+RT
       ZMN=Z-RT
       ROGSM2=X2+Y2
       SPL=DSQRT(ZPL**2+ROGSM2)
       SMN=DSQRT(ZMN**2+ROGSM2)
       XSXC=X-SXC
       RQC2=1.D0/(XSXC**2+XLWC2)
       RQC=DSQRT(RQC2)
       FYC=1.D0/(1.D0+Y2*RDYC2)
       WC=0.5D0*(1.D0-XSXC*RQC)*FYC
       DWCX=HLWC2M*RQC2*RQC*FYC
       DWCY=DRDYC2*WC*FYC*Y
       SZRP=1.D0/(SPL+ZPL)
       SZRM=1.D0/(SMN-ZMN)
       XYWC=X*DWCX+Y*DWCY
       WCSP=WC/SPL
       WCSM=WC/SMN
       FXYP=WCSP*SZRP
       FXYM=WCSM*SZRM
       FXPL=X*FXYP
       FXMN=-X*FXYM
       FYPL=Y*FXYP
       FYMN=-Y*FXYM
       FZPL=WCSP+XYWC*SZRP
       FZMN=WCSM+XYWC*SZRM
       DER(1,3)=FXPL+FXMN
       DER(1,4)=(FXPL-FXMN)*SPS
       DER(2,3)=FYPL+FYMN
       DER(2,4)=(FYPL-FYMN)*SPS
       DER(3,3)=FZPL+FZMN
       DER(3,4)=(FZPL-FZMN)*SPS
!
!   NOW CALCULATE CONTRIBUTION FROM CHAPMAN-FERRARO SOURCES + ALL OTHER
!
           EX=DEXP(X/DX)
           EC=EX*CPS
           ES=EX*SPS
           ECZ=EC*Z
           ESZ=ES*Z
         ESZY2=ESZ*Y2
         ESZZ2=ESZ*Z2
         ECZ2=ECZ*Z
         ESY=ES*Y
!
         DER(1,6)=ECZ
         DER(1,7)=ES
         DER(1,8)=ESY*Y
         DER(1,9)=ESZ*Z
         DER(2,10)=ECZ*Y
         DER(2,11)=ESY
         DER(2,12)=ESY*Y2
         DER(2,13)=ESY*Z2
         DER(3,14)=EC
         DER(3,15)=EC*Y2
         DER(3,6)=ECZ2*W1
         DER(3,10)=ECZ2*W5
         DER(3,7)=ESZ*W2
         DER(3,11)=-ESZ
         DER(3,8)=ESZY2*W2
         DER(3,12)=ESZY2*W6
         DER(3,9)=ESZZ2*W3
         DER(3,13)=ESZZ2*W4
!
!  FINALLY, CALCULATE NET EXTERNAL MAGNETIC FIELD COMPONENTS,
!    BUT FIRST OF ALL THOSE FOR C.-F. FIELD:
!
      SX1=AK6*DER(1,6)+AK7*DER(1,7)+AK8*DER(1,8)+AK9*DER(1,9)
      SY1=AK10*DER(2,10)+AK11*DER(2,11)+AK12*DER(2,12)+AK13*DER(2,13)
      SZ1=AK14*DER(3,14)+AK15*DER(3,15)+AK610*ECZ2+AK711*ESZ+AK812 &
       *ESZY2+AK913*ESZZ2
       BXCL=AK3*DER(1,3)+AK4*DER(1,4)
       BYCL=AK3*DER(2,3)+AK4*DER(2,4)
       BZCL=AK3*DER(3,3)+AK4*DER(3,4)
       BXT=AK1*DER(1,1)+AK2*DER(1,2)+BXCL +AK16*DER(1,16)+AK17*DER(1,17)
       BYT=AK1*DER(2,1)+AK2*DER(2,2)+BYCL +AK16*DER(2,16)+AK17*DER(2,17)
       BZT=AK1*DER(3,1)+AK2*DER(3,2)+BZCL +AK16*DER(3,16)+AK17*DER(3,17)
       F(1)=BXT+AK5*DER(1,5)+SX1+SXA
       F(2)=BYT+AK5*DER(2,5)+SY1+SYA
       F(3)=BZT+AK5*DER(3,5)+SZ1+SZA
!
       RETURN
       END

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

!     Fin du modele T89C
!
!
!     Debut du modele T96_01, fichier T96.txt, telecharger le 17/11/05
!

!----------------------------------------------------------------------
!
      SUBROUTINE T96_01 (IOPT,PARMOD,PS,X,Y,Z,BX,BY,BZ)
!
!     RELEASE DATE OF THIS VERSION:   JUNE 22, 1996.

!----------------------------------------------------------------------
!
!  WITH TWO CORRECTIONS, SUGGESTED BY T.SOTIRELIS' COMMENTS (APR.7, 1997)
!
!  (1) A "STRAY "  CLOSING PARENTHESIS WAS REMOVED IN THE S/R   R2_BIRK
!  (2) A 0/0 PROBLEM ON THE Z-AXIS WAS SIDESTEPPED (LINES 44-46 OF THE
!       DOUBLE PRECISION FUNCTION XKSI)
!--------------------------------------------------------------------
! DATA-BASED MODEL CALIBRATED BY (1) SOLAR WIND PRESSURE PDYN (NANOPASCALS),
!           (2) DST (NANOTESLA),  (3) BYIMF, AND (4) BZIMF (NANOTESLA).
! THESE INPUT PARAMETERS SHOULD BE PLACED IN THE FIRST 4 ELEMENTS
! OF THE ARRAY PARMOD(10).
!
!   THE REST OF THE INPUT VARIABLES ARE: THE GEODIPOLE TILT ANGLE PS (RADIANS),
! AND   X,Y,Z -  GSM POSITION (RE)
!
!   IOPT  IS JUST A DUMMY INPUT PARAMETER, NECESSARY TO MAKE THIS SUBROUTINE
! COMPATIBLE WITH THE NEW RELEASE (APRIL 1996) OF THE TRACING SOFTWARE
! PACKAGE (GEOPACK). IOPT VALUE DOES NOT AFFECT THE OUTPUT FIELD.
!
!
! OUTPUT:  GSM COMPONENTS OF THE EXTERNAL MAGNETIC FIELD (BX,BY,BZ, nanotesla)
!            COMPUTED AS A SUM OF CONTRIBUTIONS FROM PRINCIPAL FIELD SOURCES
!
!  (C) Copr. 1995, 1996, Nikolai A. Tsyganenko, Raytheon STX, Code 695, NASA GSFC
!      Greenbelt, MD 20771, USA
!
!                            REFERENCES:
!
!               (1) N.A. TSYGANENKO AND D.P. STERN, A NEW-GENERATION GLOBAL
!           MAGNETOSPHERE FIELD MODEL  , BASED ON SPACECRAFT MAGNETOMETER DATA,
!           ISTP NEWSLETTER, V.6, NO.1, P.21, FEB.1996.
!
!              (2) N.A.TSYGANENKO,  MODELING THE EARTH'S MAGNETOSPHERIC
!           MAGNETIC FIELD CONFINED WITHIN A REALISTIC MAGNETOPAUSE,
!           J.GEOPHYS.RES., V.100, P. 5599, 1995.
!
!              (3) N.A. TSYGANENKO AND M.PEREDO, ANALYTICAL MODELS OF THE
!           MAGNETIC FIELD OF DISK-SHAPED CURRENT SHEETS, J.GEOPHYS.RES.,
!           V.99, P. 199, 1994.
!
!----------------------------------------------------------------------

      IMPLICIT REAL*8 (A-H,O-Z)
      REAL PDYN,DST,BYIMF,BZIMF,PS,X,Y,Z,BX,BY,BZ,QX,QY,QZ,PARMOD(10), &
         A(9)
!
      DATA PDYN0,EPS10 /2.d0,3630.7d0/
!
      DATA A/1.162,22.344,18.50,2.602,6.903,5.287,0.5790,0.4462,0.7850/
!
      DATA  AM0,S0,X00,DSIG/70.d0,1.08d0,5.48d0,0.005d0/
      DATA  DELIMFX,DELIMFY /20.d0,10.d0/

      save
!inut
iopt=0
!
       PDYN=PARMOD(1)
       DST=PARMOD(2)
       BYIMF=PARMOD(3)
       BZIMF=PARMOD(4)
!
       SPS=SIN(dble(PS))
! jah, foresys : Result of assignment to PPS is not used
! jah,       PPS=PS
!
       DEPR=0.8d0*dble(DST)-13.d0*SQRT(dble(PDYN))  !  DEPR is an estimate of total near-Earth
!                                         depression, based on DST and Pdyn
!                                             (usually, DEPR < 0 )
!
!  CALCULATE THE IMF-RELATED QUANTITIES:
!
       Bt=dble(SQRT(BYIMF**2+BZIMF**2))

       IF (BYIMF.EQ.0..AND.BZIMF.EQ.0.) THEN
          THETA=0.d0
          GOTO 1
       ENDIF
!
       THETA=dble(ATAN2(BYIMF,BZIMF))
       IF (THETA.LE.0.D0) THETA=THETA+6.2831853d0
  1    CT=COS(THETA)
       ST=SIN(THETA)
       EPS=718.5d0*SQRT(dble(Pdyn))*Bt*SIN(THETA/2.d0)
!
       FACTEPS=EPS/EPS10-1.d0
       FACTPD=SQRT(dble(PDYN)/PDYN0)-1.d0
!
       RCAMPL=-dble(A(1))*DEPR     !   RCAMPL is the amplitude of the ring current
!                  (positive and equal to abs.value of RC depression at origin)
!
       TAMPL2=dble(A(2)+A(3))*FACTPD+dble(A(4))*FACTEPS
       TAMPL3=dble(A(5)+A(6))*FACTPD
       B1AMPL=dble(A(7)+A(8))*FACTEPS
       B2AMPL=20.d0*B1AMPL  ! IT IS EQUIVALENT TO ASSUMING THAT THE TOTAL CURRENT
!                           IN THE REGION 2 SYSTEM IS 40% OF THAT IN REGION 1
       RECONN=dble(A(9))
!
       XAPPA=(dble(PDYN)/PDYN0)**0.14d0
       XAPPA3=XAPPA**3
       YS=dble(Y)*CT-dble(Z)*ST
       ZS=dble(Z)*CT+dble(Y)*ST
!
       FACTIMF=EXP(dble(X)/DELIMFX-(YS/DELIMFY)**2)
!
!  CALCULATE THE "IMF" COMPONENTS OUTSIDE THE LAYER  (HENCE BEGIN WITH "O")
!
       OIMFX=0.d0
       OIMFY=RECONN*dble(BYIMF)*FACTIMF
       OIMFZ=RECONN*dble(BZIMF)*FACTIMF
!
       RIMFAMPL=RECONN*Bt
!
       PPS=dble(PS)
       XX=dble(X)*XAPPA
       YY=dble(Y)*XAPPA
       ZZ=dble(Z)*XAPPA
!
!  SCALE AND CALCULATE THE MAGNETOPAUSE PARAMETERS FOR THE INTERPOLATION ACROSS
!   THE BOUNDARY LAYER (THE COORDINATES XX,YY,ZZ  ARE ALREADY SCALED)
!
       X0=X00/XAPPA
       AM=AM0/XAPPA
       RHO2=dble(Y**2+Z**2)
       ASQ=AM**2
       XMXM=AM+dble(X)-X0
       IF (XMXM.LT.0.d0) XMXM=0.d0 ! THE BOUNDARY IS A CYLINDER TAILWARD OF X=X0-AM
       AXX0=XMXM**2
       ARO=ASQ+RHO2
       SIGMA=SQRT((ARO+AXX0+SQRT((ARO+AXX0)**2-4.d0*ASQ*AXX0))/(2.d0*ASQ))
!
!   NOW, THERE ARE THREE POSSIBLE CASES:
!    (1) INSIDE THE MAGNETOSPHERE
!    (2) IN THE BOUNDARY LAYER
!    (3) OUTSIDE THE MAGNETOSPHERE AND B.LAYER
!       FIRST OF ALL, CONSIDER THE CASES (1) AND (2):
!
      IF (SIGMA.LT.S0+DSIG) THEN  !  CALCULATE THE T95_06 FIELD (WITH THE
!                                POTENTIAL "PENETRATED" INTERCONNECTION FIELD):

       CALL DIPSHLD(PPS,XX,YY,ZZ,CFX,CFY,CFZ)
       CALL TAILRC96(SPS,XX,YY,ZZ,BXRC,BYRC,BZRC,BXT2,BYT2,BZT2, &
         BXT3,BYT3,BZT3)
       CALL BIRK1TOT_02(PPS,XX,YY,ZZ,R1X,R1Y,R1Z)
       CALL BIRK2TOT_02(PPS,XX,YY,ZZ,R2X,R2Y,R2Z)
       CALL INTERCON(XX,YS*XAPPA,ZS*XAPPA,RIMFX,RIMFYS,RIMFZS)
       RIMFY=RIMFYS*CT+RIMFZS*ST
       RIMFZ=RIMFZS*CT-RIMFYS*ST
!
      FX=CFX*XAPPA3+RCAMPL*BXRC +TAMPL2*BXT2+TAMPL3*BXT3 &
        +B1AMPL*R1X +B2AMPL*R2X +RIMFAMPL*RIMFX
      FY=CFY*XAPPA3+RCAMPL*BYRC +TAMPL2*BYT2+TAMPL3*BYT3 &
        +B1AMPL*R1Y +B2AMPL*R2Y +RIMFAMPL*RIMFY
      FZ=CFZ*XAPPA3+RCAMPL*BZRC +TAMPL2*BZT2+TAMPL3*BZT3 &
        +B1AMPL*R1Z +B2AMPL*R2Z +RIMFAMPL*RIMFZ
!
!  NOW, LET US CHECK WHETHER WE HAVE THE CASE (1). IF YES - WE ARE DONE:
!
       IF (SIGMA.LT.S0-DSIG) THEN
         BX=sngl(FX)
         BY=sngl(FY)
         BZ=sngl(FZ)
                        ELSE  !  THIS IS THE MOST COMPLEX CASE: WE ARE INSIDE
!                                         THE INTERPOLATION REGION
       FINT=0.5d0*(1.d0-(SIGMA-S0)/DSIG)
       FEXT=0.5d0*(1.d0+(SIGMA-S0)/DSIG)
!
       CALL DIPOLE_T96(PS,X,Y,Z,QX,QY,QZ)
       BX=sngl((FX+dble(QX))*FINT+OIMFX*FEXT) -QX
       BY=sngl((FY+dble(QY))*FINT+OIMFY*FEXT) -QY
       BZ=sngl((FZ+dble(QZ))*FINT+OIMFZ*FEXT) -QZ
!
        ENDIF  !   THE CASES (1) AND (2) ARE EXHAUSTED; THE ONLY REMAINING
!                      POSSIBILITY IS NOW THE CASE (3):
         ELSE
                CALL DIPOLE_T96(PS,X,Y,Z,QX,QY,QZ)
                BX=sngl(OIMFX)-QX
                BY=sngl(OIMFY)-QY
                BZ=sngl(OIMFZ)-QZ
         ENDIF
!
       RETURN
       END

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

      SUBROUTINE DIPSHLD(PS,X,Y,Z,BX,BY,BZ)
!
!   CALCULATES GSM COMPONENTS OF THE EXTERNAL MAGNETIC FIELD DUE TO
!    SHIELDING OF THE EARTH'S DIPOLE ONLY
!
       IMPLICIT REAL*8 (A-H,O-Z)
       DIMENSION A1(12),A2(12)
      DATA A1 /.24777d0,-27.003d0,-.46815d0,7.0637d0,-1.5918d0,-.90317d-01,57.522d0, &
       13.757d0,2.0100d0,10.458d0,4.5798d0,2.1695d0/
      DATA A2/-.65385d0,-18.061d0,-.40457d0,-5.0995d0,1.2846d0,.78231d-01,39.592d0, &
       13.291d0,1.9970d0,10.062d0,4.5140d0,2.1558d0/
!
          CPS=DCOS(PS)
          SPS=DSIN(PS)
          CALL CYLHARM(A1,X,Y,Z,HX,HY,HZ)
          CALL CYLHAR1(A2,X,Y,Z,FX,FY,FZ)
!
          BX=HX*CPS+FX*SPS
          BY=HY*CPS+FY*SPS
          BZ=HZ*CPS+FZ*SPS
        RETURN
       END
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
!  THIS CODE YIELDS THE SHIELDING FIELD FOR THE PERPENDICULAR DIPOLE
!
         SUBROUTINE  CYLHARM( A, X,Y,Z, BX,BY,BZ)
!
!
!   ***  N.A. Tsyganenko ***  Sept. 14-18, 1993; revised March 16, 1994 ***
!
!   An approximation for the Chapman-Ferraro field by a sum of 6 cylin-
!   drical harmonics (see pp. 97-113 in the brown GSFC notebook #1)
!
!      Description of parameters:
!
!  A   - input vector containing model parameters;
!  X,Y,Z   -  input GSM coordinates
!  BX,BY,BZ - output GSM components of the shielding field
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  The 6 linear parameters A(1)-A(6) are amplitudes of the cylindrical harmonic
!       terms.
!  The 6 nonlinear parameters A(7)-A(12) are the corresponding scale lengths
!       for each term (see GSFC brown notebook).
!
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!
       IMPLICIT  REAL * 8  (A - H, O - Z)
!
       DIMENSION  A(12)
      save
!
           RHO=DSQRT(Y**2+Z**2)
            IF (RHO.LT.1.D-8) THEN
               SINFI=1.D0
               COSFI=0.D0
               RHO=1.D-8
               GOTO 1
            ENDIF
!
           SINFI=Z/RHO
           COSFI=Y/RHO
  1        SINFI2=SINFI**2
           SI2CO2=SINFI2-COSFI**2
!
             BX=0.D0
             BY=0.D0
             BZ=0.D0
!
         DO 11 I=1,3
             DZETA=RHO/A(I+6)
             XJ0=BES(DZETA,0)
             XJ1=BES(DZETA,1)
             XEXP=DEXP(X/A(I+6))
             BX=BX-A(I)*XJ1*XEXP*SINFI
             BY=BY+A(I)*(2.D0*XJ1/DZETA-XJ0)*XEXP*SINFI*COSFI
             BZ=BZ+A(I)*(XJ1/DZETA*SI2CO2-XJ0*SINFI2)*XEXP
   11        CONTINUE
!
         DO 12 I=4,6
             DZETA=RHO/A(I+6)
             XKSI=X/A(I+6)
             XJ0=BES(DZETA,0)
             XJ1=BES(DZETA,1)
             XEXP=DEXP(XKSI)
             BRHO=(XKSI*XJ0-(DZETA**2+XKSI-1.D0)*XJ1/DZETA)*XEXP*SINFI
             BPHI=(XJ0+XJ1/DZETA*(XKSI-1.D0))*XEXP*COSFI
             BX=BX+A(I)*(DZETA*XJ0+XKSI*XJ1)*XEXP*SINFI
             BY=BY+A(I)*(BRHO*COSFI-BPHI*SINFI)
             BZ=BZ+A(I)*(BRHO*SINFI+BPHI*COSFI)
   12        CONTINUE
!
!
         RETURN
       END
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
!  THIS CODE YIELDS THE SHIELDING FIELD FOR THE PARALLEL DIPOLE
!
         SUBROUTINE  CYLHAR1(A, X,Y,Z, BX,BY,BZ)
!
!
!   ***  N.A. Tsyganenko ***  Sept. 14-18, 1993; revised March 16, 1994 ***
!
!   An approximation of the Chapman-Ferraro field by a sum of 6 cylin-
!   drical harmonics (see pages 97-113 in the brown GSFC notebook #1)
!
!      Description of parameters:
!
!  A   - input vector containing model parameters;
!  X,Y,Z - input GSM coordinates,
!  BX,BY,BZ - output GSM components of the shielding field
!
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!
!      The 6 linear parameters A(1)-A(6) are amplitudes of the cylindrical
!  harmonic terms.
!      The 6 nonlinear parameters A(7)-A(12) are the corresponding scale
!  lengths for each term (see GSFC brown notebook).
!
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!
       IMPLICIT  REAL * 8  (A - H, O - Z)
!
       DIMENSION  A(12)
      save
!
           RHO=DSQRT(Y**2+Z**2)
            IF (RHO.LT.1.D-10) THEN
               SINFI=1.D0
               COSFI=0.D0
               GOTO 1
            ENDIF
!
           SINFI=Z/RHO
           COSFI=Y/RHO
!
   1      BX=0.D0
          BY=0.D0
          BZ=0.D0
!
             DO 11 I=1,3
             DZETA=RHO/A(I+6)
             XKSI=X/A(I+6)
             XJ0=BES(DZETA,0)
             XJ1=BES(DZETA,1)
             XEXP=DEXP(XKSI)
             BRHO=XJ1*XEXP
             BX=BX-A(I)*XJ0*XEXP
             BY=BY+A(I)*BRHO*COSFI
             BZ=BZ+A(I)*BRHO*SINFI
   11        CONTINUE
!
         DO 12 I=4,6
             DZETA=RHO/A(I+6)
             XKSI=X/A(I+6)
             XJ0=BES(DZETA,0)
             XJ1=BES(DZETA,1)
             XEXP=DEXP(XKSI)
             BRHO=(DZETA*XJ0+XKSI*XJ1)*XEXP
             BX=BX+A(I)*(DZETA*XJ1-XJ0*(XKSI+1.D0))*XEXP
             BY=BY+A(I)*BRHO*COSFI
             BZ=BZ+A(I)*BRHO*SINFI
   12        CONTINUE
!
         RETURN
       END

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
      DOUBLE PRECISION FUNCTION BES(X,K)
      IMPLICIT REAL*8 (A-H,O-Z)
      save
!
      IF (K.EQ.0) THEN
        BES=BES0(X)
        RETURN
      ENDIF
!
      IF (K.EQ.1) THEN
        BES=BES1(X)
        RETURN
      ENDIF
!
      IF (X.EQ.0.D0) THEN
        BES=0.D0
        RETURN
      ENDIF
!
      G=2.D0/X
      IF (X.LE.DFLOAT(K)) GOTO 10
!
      N=1
      XJN=BES1(X)
      XJNM1=BES0(X)
!
  1   XJNP1=G*dble(N)*XJN-XJNM1
      N=N+1
      IF (N.LT.K) GOTO 2
      BES=XJNP1
      RETURN
!
 2    XJNM1=XJN
      XJN=XJNP1
      GOTO 1
!
 10   N=24
      XJN=1.D0
      XJNP1=0.D0
      SUM=0.D0
!
  3   IF (MOD(N,2).EQ.0) SUM=SUM+XJN
      XJNM1=G*dble(N)*XJN-XJNP1
      N=N-1
!
      XJNP1=XJN
      XJN=XJNM1
      IF (N.EQ.K) BES=XJN
!
      IF (DABS(XJN).GT.1.D5) THEN
        XJNP1=XJNP1*1.D-5
        XJN=XJN*1.D-5
        SUM=SUM*1.D-5
        IF (N.LE.K) BES=BES*1.D-5
      ENDIF
!
      IF (N.EQ.0) GOTO 4
      GOTO 3
!
  4   SUM=XJN+2.D0*SUM
      BES=BES/SUM
      RETURN
      END

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
       DOUBLE PRECISION FUNCTION BES0(X)
!
        IMPLICIT REAL*8 (A-H,O-Z)
!
        IF (DABS(X).LT.3.D0) THEN
          X32=(X/3.D0)**2
          BES0=1.D0-X32*(2.2499997D0-X32*(1.2656208D0-X32* &
          (0.3163866D0-X32*(0.0444479D0-X32*(0.0039444D0 &
           -X32*0.00021D0)))))
        ELSE
        XD3=3.D0/X
        F0=0.79788456D0-XD3*(0.00000077D0+XD3*(0.00552740D0+XD3* &
         (0.00009512D0-XD3*(0.00137237D0-XD3*(0.00072805D0 &
         -XD3*0.00014476D0)))))
        T0=X-0.78539816D0-XD3*(0.04166397D0+XD3*(0.00003954D0-XD3* &
         (0.00262573D0-XD3*(0.00054125D0+XD3*(0.00029333D0 &
         -XD3*0.00013558D0)))))
        BES0=F0/DSQRT(X)*DCOS(T0)
       ENDIF
       RETURN
       END
!

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
       DOUBLE PRECISION FUNCTION BES1(X)
!
        IMPLICIT REAL*8 (A-H,O-Z)
      save
!
       IF (DABS(X).LT.3.D0) THEN
        X32=(X/3.D0)**2
        BES1XM1=0.5D0-X32*(0.56249985D0-X32*(0.21093573D0-X32* &
        (0.03954289D0-X32*(0.00443319D0-X32*(0.00031761D0 &
        -X32*0.00001109D0)))))
         BES1=BES1XM1*X
       ELSE
        XD3=3.D0/X
        F1=0.79788456D0+XD3*(0.00000156D0+XD3*(0.01659667D0+XD3* &
         (0.00017105D0-XD3*(0.00249511D0-XD3*(0.00113653D0 &
         -XD3*0.00020033D0)))))
        T1=X-2.35619449D0+XD3*(0.12499612D0+XD3*(0.0000565D0-XD3* &
         (0.00637879D0-XD3*(0.00074348D0+XD3*(0.00079824D0 &
         -XD3*0.00029166D0)))))
        BES1=F1/DSQRT(X)*DCOS(T1)
       ENDIF
       RETURN
       END

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
         SUBROUTINE INTERCON(X,Y,Z,BX,BY,BZ)
!
!      Calculates the potential interconnection field inside the magnetosphere,
!  corresponding to  DELTA_X = 20Re and DELTA_Y = 10Re (NB#3, p.90, 6/6/1996).
!  The position (X,Y,Z) and field components BX,BY,BZ are given in the rotated
!   coordinate system, in which the Z-axis is always directed along the BzIMF
!   (i.e. rotated by the IMF clock angle Theta)
!   It is also assumed that the IMF Bt=1, so that the components should be
!     (i) multiplied by the actual Bt, and
!     (ii) transformed to standard GSM coords by rotating back around X axis
!              by the angle -Theta.
!
!      Description of parameters:
!
!     X,Y,Z -   GSM POSITION
!      BX,BY,BZ - INTERCONNECTION FIELD COMPONENTS INSIDE THE MAGNETOSPHERE
!        OF A STANDARD SIZE (TO TAKE INTO ACCOUNT EFFECTS OF PRESSURE CHANGES,
!         APPLY THE SCALING TRANSFORMATION)
!
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!
!     The 9 linear parameters are amplitudes of the "cartesian" harmonics
!     The 6 nonlinear parameters are the scales Pi and Ri entering
!    the arguments of exponents, sines, and cosines in the 9 "Cartesian"
!       harmonics (3+3)
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!
       IMPLICIT  REAL * 8  (A - H, O - Z)
!
        DIMENSION A(15),RP(3),RR(3),P(3),R(3)
      save
!
      DATA A/-8.411078731d0,5932254.951d0,-9073284.93d0,-11.68794634d0, &
       6027598.824d0,-9218378.368d0,-6.508798398d0,-11824.42793d0,18015.66212d0, &
       7.99754043d0,13.9669886d0,90.24475036d0,16.75728834d0,1015.645781d0, &
       1553.493216d0/
!
        DATA M/0/
!
        IF (M.NE.0) GOTO 111
        M=1
!
         P(1)=A(10)
         P(2)=A(11)
         P(3)=A(12)
         R(1)=A(13)
         R(2)=A(14)
         R(3)=A(15)
!
!
           DO 11 I=1,3
            RP(I)=1.D0/P(I)
  11        RR(I)=1.D0/R(I)
!
  111   CONTINUE
!
            L=0
!
               BX=0.d0
               BY=0.d0
               BZ=0.d0
!
!        "PERPENDICULAR" KIND OF SYMMETRY ONLY
!
               DO 2 I=1,3
                  CYPI=DCOS(Y*RP(I))
                  SYPI=DSIN(Y*RP(I))
!
                DO 2 K=1,3
                   SZRK=DSIN(Z*RR(K))
                   CZRK=DCOS(Z*RR(K))
                     SQPR=DSQRT(RP(I)**2+RR(K)**2)
                      EPR=DEXP(X*SQPR)
!
                     HX=-SQPR*EPR*CYPI*SZRK
                     HY=RP(I)*EPR*SYPI*SZRK
                     HZ=-RR(K)*EPR*CYPI*CZRK
             L=L+1
!
          BX=BX+A(L)*HX
          BY=BY+A(L)*HY
          BZ=BZ+A(L)*HZ
  2   CONTINUE
!
      RETURN
      END

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

      SUBROUTINE TAILRC96(SPS,X,Y,Z,BXRC,BYRC,BZRC,BXT2,BYT2,BZT2, &
         BXT3,BYT3,BZT3)
!
!  COMPUTES THE COMPONENTS OF THE FIELD OF THE MODEL RING CURRENT AND THREE
!                   TAIL MODES WITH UNIT AMPLITUDES
!      (FOR THE RING CURRENT, IT MEANS THE DISTURBANCE OF Bz=-1nT AT ORIGIN,
!   AND FOR THE TAIL MODES IT MEANS MAXIMAL BX JUST ABOVE THE SHEET EQUAL 1 nT.
!
         IMPLICIT REAL*8 (A-H,O-Z)
         DIMENSION ARC(48),ATAIL2(48),ATAIL3(48)
      save
         COMMON /WARP/ CPSS,SPSS,DPSRR,RPS,WARP,D,XS,ZS,DXSX,DXSY,DXSZ, &
         DZSX,DZSY,DZSZ,DZETAS,DDZETADX,DDZETADY,DDZETADZ,ZSWW
!
         DATA ARC/-3.087699646d0,3.516259114d0,18.81380577d0,-13.95772338d0, &
        -5.497076303d0,0.1712890838d0,2.392629189d0,-2.728020808d0,-14.79349936d0, &
        11.08738083d0,4.388174084d0,0.2492163197d-01,0.7030375685d0, &
      -.7966023165d0,-3.835041334d0,2.642228681d0,-0.2405352424d0,-0.7297705678d0, &
       -0.3680255045d0,0.1333685557d0,2.795140897d0,-1.078379954d0,0.8014028630d0, &
       0.1245825565d0,0.6149982835d0,-0.2207267314d0,-4.424578723d0,1.730471572d0, &
       -1.716313926d0,-0.2306302941d0,-0.2450342688d0,0.8617173961d-01, &
        1.54697858d0,-0.6569391113d0,-0.6537525353d0,0.2079417515d0,12.75434981d0, &
        11.37659788d0,636.4346279d0,1.752483754d0,3.604231143d0,12.83078674d0, &
       7.412066636d0,9.434625736d0,676.7557193d0,1.701162737d0,3.580307144d0, &
        14.64298662d0/
!
        DATA ATAIL2/.8747515218d0,-.9116821411d0,2.209365387d0,-2.159059518d0, &
       -7.059828867d0,5.924671028d0,-1.916935691d0,1.996707344d0,-3.877101873d0, &
       3.947666061d0,11.38715899d0,-8.343210833d0,1.194109867d0,-1.244316975d0, &
       3.73895491d0,-4.406522465d0,-20.66884863d0,3.020952989d0,.2189908481d0, &
       -.09942543549d0,-.927225562d0,.1555224669d0,.6994137909d0,-.08111721003d0, &
       -.7565493881d0,.4686588792d0,4.266058082d0,-.3717470262d0,-3.920787807d0, &
       .02298569870d0,.7039506341d0,-.5498352719d0,-6.675140817d0,.8279283559d0, &
       -2.234773608d0,-1.622656137d0,5.187666221d0,6.802472048d0,39.13543412d0, &
        2.784722096d0,6.979576616d0,25.71716760d0,4.495005873d0,8.068408272d0, &
       93.47887103d0,4.158030104d0,9.313492566d0,57.18240483d0/
!
        DATA ATAIL3/-19091.95061d0,-3011.613928d0,20582.16203d0,4242.918430d0, &
       -2377.091102d0,-1504.820043d0,19884.04650d0,2725.150544d0,-21389.04845d0, &
       -3990.475093d0,2401.610097d0,1548.171792d0,-946.5493963d0,490.1528941d0, &
       986.9156625d0,-489.3265930d0,-67.99278499d0,8.711175710d0,-45.15734260d0, &
       -10.76106500d0,210.7927312d0,11.41764141d0,-178.0262808d0,.7558830028d0, &
        339.3806753d0,9.904695974d0,69.50583193d0,-118.0271581d0,22.85935896d0, &
       45.91014857d0,-425.6607164d0,15.47250738d0,118.2988915d0,65.58594397d0, &
       -201.4478068d0,-14.57062940d0,19.69877970d0,20.30095680d0,86.45407420d0, &
       22.50403727d0,23.41617329d0,48.48140573d0,24.61031329d0,123.5395974d0, &
       223.5367692d0,39.50824342d0,65.83385762d0,266.2948657d0/
!
       DATA RH,DR,G,D0,DELTADY/9.d0,4.d0,10.d0,2.d0,10.d0/
!
!   TO ECONOMIZE THE CODE, WE FIRST CALCULATE COMMON VARIABLES, WHICH ARE
!      THE SAME FOR ALL MODES, AND PUT THEM IN THE COMMON-BLOCK /WARP/
!
       DR2=DR*DR
       C11=DSQRT((1.D0+RH)**2+DR2)
       C12=DSQRT((1.D0-RH)**2+DR2)
       C1=C11-C12
       SPSC1=SPS/C1
       RPS=0.5d0*(C11+C12)*SPS  !  THIS IS THE SHIFT OF OF THE SHEET WITH RESPECT
!                            TO GSM EQ.PLANE FOR THE 3RD (ASYMPTOTIC) TAIL MODE
!
        R=DSQRT(X*X+Y*Y+Z*Z)
        SQ1=DSQRT((R+RH)**2+DR2)
        SQ2=DSQRT((R-RH)**2+DR2)
        C=SQ1-SQ2
        CS=(R+RH)/SQ1-(R-RH)/SQ2
        SPSS=SPSC1/R*C
        CPSS=DSQRT(1.D0-SPSS**2)
        DPSRR=SPS/(R*R)*(CS*R-C)/DSQRT((R*C1)**2-(C*SPS)**2)
!
        WFAC=Y/(Y**4+1.D4)   !   WARPING
        W=WFAC*Y**3
        WS=4.D4*Y*WFAC**2
        WARP=G*SPS*W
        XS=X*CPSS-Z*SPSS
        ZSWW=Z*CPSS+X*SPSS  ! "WW" MEANS "WITHOUT Y-Z WARPING" (IN X-Z ONLY)
        ZS=ZSWW +WARP

        DXSX=CPSS-X*ZSWW*DPSRR
        DXSY=-Y*ZSWW*DPSRR
        DXSZ=-SPSS-Z*ZSWW*DPSRR
        DZSX=SPSS+X*XS*DPSRR
        DZSY=XS*Y*DPSRR  +G*SPS*WS  !  THE LAST TERM IS FOR THE Y-Z WARP
        DZSZ=CPSS+XS*Z*DPSRR        !      (TAIL MODES ONLY)

        D=D0+DELTADY*(Y/20.D0)**2   !  SHEET HALF-THICKNESS FOR THE TAIL MODES
        DDDY=DELTADY*Y*0.005D0      !  (THICKENS TO FLANKS, BUT NO VARIATION
!                                         ALONG X, IN CONTRAST TO RING CURRENT)
!
        DZETAS=DSQRT(ZS**2+D**2)  !  THIS IS THE SAME SIMPLE WAY TO SPREAD
!                                        OUT THE SHEET, AS THAT USED IN T89
        DDZETADX=ZS*DZSX/DZETAS
        DDZETADY=(ZS*DZSY+D*DDDY)/DZETAS
        DDZETADZ=ZS*DZSZ/DZETAS
!
        CALL SHLCAR3X3_T96(ARC,X,Y,Z,SPS,WX,WY,WZ)
        CALL RINGCURR96(X,Y,Z,HX,HY,HZ)
        BXRC=WX+HX
        BYRC=WY+HY
        BZRC=WZ+HZ
!
        CALL SHLCAR3X3_T96(ATAIL2,X,Y,Z,SPS,WX,WY,WZ)
        CALL TAILDISK_T96(X,Y,Z,HX,HY,HZ)
        BXT2=WX+HX
        BYT2=WY+HY
        BZT2=WZ+HZ
!
        CALL SHLCAR3X3_T96(ATAIL3,X,Y,Z,SPS,WX,WY,WZ)
        CALL TAIL87(X,Z,HX,HZ)
        BXT3=WX+HX
        BYT3=WY
        BZT3=WZ+HZ
!
        RETURN
        END
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
        SUBROUTINE RINGCURR96(X,Y,Z,BX,BY,BZ)
!
!       THIS SUBROUTINE COMPUTES THE COMPONENTS OF THE RING CURRENT FIELD,
!        SIMILAR TO THAT DESCRIBED BY TSYGANENKO AND PEREDO (1994).  THE
!          DIFFERENCE IS THAT NOW WE USE SPACEWARPING, AS DESCRIBED IN THE
!           PAPER ON MODELING BIRKELAND CURRENTS (TSYGANENKO AND STERN, 1996),
!            INSTEAD OF SHEARING IT IN THE SPIRIT OF THE T89 TAIL MODEL.
!
!          IN  ADDITION, INSTEAD OF 7 TERMS FOR THE RING CURRENT MODEL, WE USE
!             NOW ONLY 2 TERMS;  THIS SIMPLIFICATION ALSO GIVES RISE TO AN
!                EASTWARD RING CURRENT LOCATED EARTHWARD FROM THE MAIN ONE,
!                  IN LINE WITH WHAT IS ACTUALLY OBSERVED
!
!             FOR DETAILS, SEE NB #3, PAGES 70-73
!
        IMPLICIT REAL*8 (A-H,O-Z)
        DIMENSION F(2),BETA(2)
      save
        COMMON /WARP/ CPSS,SPSS,DPSRR, BID4,BID5,BID6,XS,ZSWARPED,DXSX, &
             DXSY,DXSZ,DZSX,DZSYWARPED,DZSZ,BID15,BID16,BID17,BID18,ZS !  ZS HERE IS WITHOUT Y-Z WARP
!

      DATA D0,DELTADX,XD,XLDX /2.d0,0.d0,0.d0,4.d0/  !  ACHTUNG !!  THE RC IS NOW
!                                            COMPLETELY SYMMETRIC (DELTADX=0)

!
        DATA F,BETA /569.895366D0,-1603.386993D0,2.722188D0,3.766875D0/
!
!  THE ORIGINAL VALUES OF F(I) WERE MULTIPLIED BY BETA(I) (TO REDUCE THE
!     NUMBER OF MULTIPLICATIONS BELOW)  AND BY THE FACTOR -0.43, NORMALIZING
!      THE DISTURBANCE AT ORIGIN  TO  B=-1nT
!
           DZSY=XS*Y*DPSRR  ! NO WARPING IN THE Y-Z PLANE (ALONG X ONLY), AND
!                         THIS IS WHY WE DO NOT USE  DZSY FROM THE COMMON-BLOCK
           XXD=X-XD
           FDX=0.5D0*(1.D0+XXD/DSQRT(XXD**2+XLDX**2))
           DDDX=DELTADX*0.5D0*XLDX**2/DSQRT(XXD**2+XLDX**2)**3
           D=D0+DELTADX*FDX

           DZETAS=DSQRT(ZS**2+D**2)  !  THIS IS THE SAME SIMPLE WAY TO SPREAD
!                                        OUT THE SHEET, AS THAT USED IN T89
           RHOS=DSQRT(XS**2+Y**2)
           DDZETADX=(ZS*DZSX+D*DDDX)/DZETAS
           DDZETADY=ZS*DZSY/DZETAS
           DDZETADZ=ZS*DZSZ/DZETAS
         IF (RHOS.LT.1.D-5) THEN
            DRHOSDX=0.D0
            DRHOSDY=DSIGN(1.D0,Y)
            DRHOSDZ=0.D0
          ELSE
           DRHOSDX=XS*DXSX/RHOS
           DRHOSDY=(XS*DXSY+Y)/RHOS
           DRHOSDZ=XS*DXSZ/RHOS
         ENDIF
!
           BX=0.D0
           BY=0.D0
           BZ=0.D0
!
           DO 1 I=1,2
!
           BI=BETA(I)
!
           S1=DSQRT((DZETAS+BI)**2+(RHOS+BI)**2)
           S2=DSQRT((DZETAS+BI)**2+(RHOS-BI)**2)
           DS1DDZ=(DZETAS+BI)/S1
           DS2DDZ=(DZETAS+BI)/S2
           DS1DRHOS=(RHOS+BI)/S1
           DS2DRHOS=(RHOS-BI)/S2
!
           DS1DX=DS1DDZ*DDZETADX+DS1DRHOS*DRHOSDX
           DS1DY=DS1DDZ*DDZETADY+DS1DRHOS*DRHOSDY
           DS1DZ=DS1DDZ*DDZETADZ+DS1DRHOS*DRHOSDZ
!
           DS2DX=DS2DDZ*DDZETADX+DS2DRHOS*DRHOSDX
           DS2DY=DS2DDZ*DDZETADY+DS2DRHOS*DRHOSDY
           DS2DZ=DS2DDZ*DDZETADZ+DS2DRHOS*DRHOSDZ
!
           S1TS2=S1*S2
           S1PS2=S1+S2
           S1PS2SQ=S1PS2**2
           FAC1=DSQRT(S1PS2SQ-(2.D0*BI)**2)
           AS=FAC1/(S1TS2*S1PS2SQ)
           TERM1=1.D0/(S1TS2*S1PS2*FAC1)
           FAC2=AS/S1PS2SQ
           DASDS1=TERM1-FAC2/S1*(S2*S2+S1*(3.D0*S1+4.D0*S2))
           DASDS2=TERM1-FAC2/S2*(S1*S1+S2*(3.D0*S2+4.D0*S1))
!
           DASDX=DASDS1*DS1DX+DASDS2*DS2DX
           DASDY=DASDS1*DS1DY+DASDS2*DS2DY
           DASDZ=DASDS1*DS1DZ+DASDS2*DS2DZ
!
      BX=BX+F(I)*((2.D0*AS+Y*DASDY)*SPSS-XS*DASDZ &
         +AS*DPSRR*(Y**2*CPSS+Z*ZS))
      BY=BY-F(I)*Y*(AS*DPSRR*XS+DASDZ*CPSS+DASDX*SPSS)
  1   BZ=BZ+F(I)*((2.D0*AS+Y*DASDY)*CPSS+XS*DASDX &
         -AS*DPSRR*(X*ZS+Y**2*SPSS))
!
       RETURN
       END
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
         SUBROUTINE TAILDISK_T96(X,Y,Z,BX,BY,BZ)
!
!
!       THIS SUBROUTINE COMPUTES THE COMPONENTS OF THE TAIL CURRENT FIELD,
!        SIMILAR TO THAT DESCRIBED BY TSYGANENKO AND PEREDO (1994).  THE
!          DIFFERENCE IS THAT NOW WE USE SPACEWARPING, AS DESCRIBED IN OUR
!           PAPER ON MODELING BIRKELAND CURRENTS (TSYGANENKO AND STERN, 1996)
!            INSTEAD OF SHEARING IT IN THE SPIRIT OF T89 TAIL MODEL.
!
!          IN  ADDITION, INSTEAD OF 8 TERMS FOR THE TAIL CURRENT MODEL, WE USE
!           NOW ONLY 4 TERMS
!
!             FOR DETAILS, SEE NB #3, PAGES 74-
!
         IMPLICIT REAL*8 (A-H,O-Z)
         DIMENSION F(4),BETA(4)
      save
         COMMON /WARP/ CPSS,SPSS,DPSRR,BID4,BID5,BID6,XS,ZS,DXSX,DXSY, &
              DXSZ,BID12,BID13,BID14,DZETAS,DDZETADX,DDZETADY,DDZETADZ, &
              ZSWW
!
         DATA XSHIFT /4.5d0/
!
         DATA F,BETA &
       / -745796.7338D0,1176470.141D0,-444610.529D0,-57508.01028D0, &
         7.9250000D0,8.0850000D0,8.4712500D0,27.89500D0/
!
!  here original F(I) are multiplied by BETA(I), to economize
!    calculations
!
           RHOS=DSQRT((XS-XSHIFT)**2+Y**2)
         IF (RHOS.LT.1.D-5) THEN
            DRHOSDX=0.D0
            DRHOSDY=DSIGN(1.D0,Y)
            DRHOSDZ=0.D0
         ELSE
           DRHOSDX=(XS-XSHIFT)*DXSX/RHOS
           DRHOSDY=((XS-XSHIFT)*DXSY+Y)/RHOS
           DRHOSDZ=(XS-XSHIFT)*DXSZ/RHOS
         ENDIF
!
           BX=0.D0
           BY=0.D0
           BZ=0.D0
!
           DO 1 I=1,4
!
           BI=BETA(I)
!
           S1=DSQRT((DZETAS+BI)**2+(RHOS+BI)**2)
           S2=DSQRT((DZETAS+BI)**2+(RHOS-BI)**2)
           DS1DDZ=(DZETAS+BI)/S1
           DS2DDZ=(DZETAS+BI)/S2
           DS1DRHOS=(RHOS+BI)/S1
           DS2DRHOS=(RHOS-BI)/S2
!
           DS1DX=DS1DDZ*DDZETADX+DS1DRHOS*DRHOSDX
           DS1DY=DS1DDZ*DDZETADY+DS1DRHOS*DRHOSDY
           DS1DZ=DS1DDZ*DDZETADZ+DS1DRHOS*DRHOSDZ
!
           DS2DX=DS2DDZ*DDZETADX+DS2DRHOS*DRHOSDX
           DS2DY=DS2DDZ*DDZETADY+DS2DRHOS*DRHOSDY
           DS2DZ=DS2DDZ*DDZETADZ+DS2DRHOS*DRHOSDZ
!
           S1TS2=S1*S2
           S1PS2=S1+S2
           S1PS2SQ=S1PS2**2
           FAC1=DSQRT(S1PS2SQ-(2.D0*BI)**2)
           AS=FAC1/(S1TS2*S1PS2SQ)
           TERM1=1.D0/(S1TS2*S1PS2*FAC1)
           FAC2=AS/S1PS2SQ
           DASDS1=TERM1-FAC2/S1*(S2*S2+S1*(3.D0*S1+4.D0*S2))
           DASDS2=TERM1-FAC2/S2*(S1*S1+S2*(3.D0*S2+4.D0*S1))
!
           DASDX=DASDS1*DS1DX+DASDS2*DS2DX
           DASDY=DASDS1*DS1DY+DASDS2*DS2DY
           DASDZ=DASDS1*DS1DZ+DASDS2*DS2DZ
!
      BX=BX+F(I)*((2.D0*AS+Y*DASDY)*SPSS-(XS-XSHIFT)*DASDZ &
         +AS*DPSRR*(Y**2*CPSS+Z*ZSWW))
!
      BY=BY-F(I)*Y*(AS*DPSRR*XS+DASDZ*CPSS+DASDX*SPSS)
  1   BZ=BZ+F(I)*((2.D0*AS+Y*DASDY)*CPSS+(XS-XSHIFT)*DASDX &
         -AS*DPSRR*(X*ZSWW+Y**2*SPSS))

       RETURN
       END

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
      SUBROUTINE TAIL87(X,Z,BX,BZ)

      IMPLICIT REAL*8 (A-H,O-Z)
      save

      COMMON /WARP/ BID1,BID2,BID3, RPS,WARP,D, BID7,BID8,BID9,BID10, &
           BID11,BID12,BID13,BID14,BID15,BID16,BID17,BID18,BID19
!
!      'LONG' VERSION OF THE 1987 TAIL MAGNETIC FIELD MODEL
!              (N.A.TSYGANENKO, PLANET. SPACE SCI., V.35, P.1347, 1987)
!
!      D   IS THE Y-DEPENDENT SHEET HALF-THICKNESS (INCREASING TOWARDS FLANKS)
!      RPS  IS THE TILT-DEPENDENT SHIFT OF THE SHEET IN THE Z-DIRECTION,
!           CORRESPONDING TO THE ASYMPTOTIC HINGING DISTANCE, DEFINED IN THE
!           MAIN SUBROUTINE (TAILRC96) FROM THE PARAMETERS RH AND DR OF THE
!           T96-TYPE MODULE, AND
!      WARP  IS THE BENDING OF THE SHEET FLANKS IN THE Z-DIRECTION, DIRECTED
!           OPPOSITE TO RPS, AND INCREASING WITH DIPOLE TILT AND |Y|
!

        DATA DD/3.d0/
!
      DATA HPI,RT,XN,X1,X2,B0,B1,B2,XN21,XNR,ADLN &
       /1.5707963d0,40.d0,-10.d0, &
       -1.261d0,-0.663d0,0.391734d0,5.89715d0,24.6833d0,76.37d0,-0.1071d0,0.13238005d0/
!                !!!   THESE ARE NEW VALUES OF  X1, X2, B0, B1, B2,
!                       CORRESPONDING TO TSCALE=1, INSTEAD OF TSCALE=0.6
!
!  THE ABOVE QUANTITIES WERE DEFINED AS FOLLOWS:------------------------
!       HPI=PI/2
!       RT=40.      !  Z-POSITION OF UPPER AND LOWER ADDITIONAL SHEETS
!       XN=-10.     !  INNER EDGE POSITION
!
!       TSCALE=1  !  SCALING FACTOR, DEFINING THE RATE OF INCREASE OF THE
!                       CURRENT DENSITY TAILWARDS
!
!  ATTENTION !  NOW I HAVE CHANGED TSCALE TO:  TSCALE=1.0, INSTEAD OF 0.6
!                  OF THE PREVIOUS VERSION
!
!       B0=0.391734
!       B1=5.89715 *TSCALE
!       B2=24.6833 *TSCALE**2
!
!    HERE ORIGINAL VALUES OF THE MODE AMPLITUDES (P.77, NB#3) WERE NORMALIZED
!      SO THAT ASYMPTOTIC  BX=1  AT X=-200RE
!
!      X1=(4.589  -5.85) *TSCALE -(TSCALE-1.)*XN ! NONLINEAR PARAMETERS OF THE
!                                                         CURRENT FUNCTION
!      X2=(5.187  -5.85) *TSCALE -(TSCALE-1.)*XN
!
!
!      XN21=(XN-X1)**2
!      XNR=1./(XN-X2)
!      ADLN=-DLOG(XNR**2*XN21)
!
!---------------------------------------------------------------
!
      ZS=Z -RPS +WARP
      ZP=Z-RT
      ZM=Z+RT
!
      XNX=XN-X
      XNX2=XNX**2
      XC1=X-X1
      XC2=X-X2
      XC22=XC2**2
      XR2=XC2*XNR
      XC12=XC1**2
      D2=DD**2    !  SQUARE OF THE TOTAL HALFTHICKNESS (DD=3Re for this mode)
      B20=ZS**2+D2
      B2P=ZP**2+D2
      B2M=ZM**2+D2
      B=DSQRT(B20)
      BP=DSQRT(B2P)
      BM=DSQRT(B2M)
      XA1=XC12+B20
      XAP1=XC12+B2P
      XAM1=XC12+B2M
      XA2=1.d0/(XC22+B20)
      XAP2=1.d0/(XC22+B2P)
      XAM2=1.d0/(XC22+B2M)
      XNA=XNX2+B20
      XNAP=XNX2+B2P
      XNAM=XNX2+B2M
      F=B20-XC22
      FP=B2P-XC22
      FM=B2M-XC22
      XLN1=DLOG(XN21/XNA)
      XLNP1=DLOG(XN21/XNAP)
      XLNM1=DLOG(XN21/XNAM)
      XLN2=XLN1+ADLN
      XLNP2=XLNP1+ADLN
      XLNM2=XLNM1+ADLN
      ALN=0.25d0*(XLNP1+XLNM1-2.d0*XLN1)
      S0=(DATAN(XNX/B)+HPI)/B
      S0P=(DATAN(XNX/BP)+HPI)/BP
      S0M=(DATAN(XNX/BM)+HPI)/BM
      S1=(XLN1*.5d0+XC1*S0)/XA1
      S1P=(XLNP1*.5d0+XC1*S0P)/XAP1
      S1M=(XLNM1*.5d0+XC1*S0M)/XAM1
      S2=(XC2*XA2*XLN2-XNR-F*XA2*S0)*XA2
      S2P=(XC2*XAP2*XLNP2-XNR-FP*XAP2*S0P)*XAP2
      S2M=(XC2*XAM2*XLNM2-XNR-FM*XAM2*S0M)*XAM2
      G1=(B20*S0-0.5d0*XC1*XLN1)/XA1
      G1P=(B2P*S0P-0.5d0*XC1*XLNP1)/XAP1
      G1M=(B2M*S0M-0.5d0*XC1*XLNM1)/XAM1
      G2=((0.5d0*F*XLN2+2.d0*S0*B20*XC2)*XA2+XR2)*XA2
      G2P=((0.5d0*FP*XLNP2+2.d0*S0P*B2P*XC2)*XAP2+XR2)*XAP2
      G2M=((0.5d0*FM*XLNM2+2.d0*S0M*B2M*XC2)*XAM2+XR2)*XAM2
      BX=B0*(ZS*S0-0.5d0*(ZP*S0P+ZM*S0M)) &
       +B1*(ZS*S1-0.5d0*(ZP*S1P+ZM*S1M))+B2*(ZS*S2-0.5d0*(ZP*S2P+ZM*S2M))
      BZ=B0*ALN+B1*(G1-0.5d0*(G1P+G1M))+B2*(G2-0.5d0*(G2P+G2M))
!
!    CALCULATION OF THE MAGNETOTAIL CURRENT CONTRIBUTION IS FINISHED
!
      RETURN
      END

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
! THIS CODE RETURNS THE SHIELDING FIELD REPRESENTED BY  2x3x3=18 "CARTESIAN"
!    HARMONICS
!
         SUBROUTINE  SHLCAR3X3_T96(A,X,Y,Z,SPS,HX,HY,HZ)
!
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  The 36 coefficients enter in pairs in the amplitudes of the "cartesian"
!    harmonics (A(1)-A(36).
!  The 12 nonlinear parameters (A(37)-A(48) are the scales Pi,Ri,Qi,and Si
!   entering the arguments of exponents, sines, and cosines in each of the
!   18 "Cartesian" harmonics
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!
       IMPLICIT  REAL * 8  (A - H, O - Z)
!
         DIMENSION A(48)
      save
!
! jah, foresys : Variable DX,DY,DZ may not have been  initialized
         data DX,DY,DZ /0.d0,0.d0,0.d0/
          CPS=DSQRT(1.D0-SPS**2)
          S3PS=4.D0*CPS**2-1.D0   !  THIS IS SIN(3*PS)/SIN(PS)
!
           HX=0.D0
           HY=0.D0
           HZ=0.D0
           L=0
!
           DO 1 M=1,2     !    M=1 IS FOR THE 1ST SUM ("PERP." SYMMETRY)
!                           AND M=2 IS FOR THE SECOND SUM ("PARALL." SYMMETRY)
             DO 2 I=1,3
                  P=A(36+I)
                  Q=A(42+I)
                  CYPI=DCOS(Y/P)
                  CYQI=DCOS(Y/Q)
                  SYPI=DSIN(Y/P)
                  SYQI=DSIN(Y/Q)
!
              DO 3 K=1,3
                   R=A(39+K)
                   S=A(45+K)
                   SZRK=DSIN(Z/R)
                   CZSK=DCOS(Z/S)
                   CZRK=DCOS(Z/R)
                   SZSK=DSIN(Z/S)
                     SQPR=DSQRT(1.D0/P**2+1.D0/R**2)
                     SQQS=DSQRT(1.D0/Q**2+1.D0/S**2)
                        EPR=DEXP(X*SQPR)
                        EQS=DEXP(X*SQQS)
!
                   DO 4 N=1,2  ! N=1 IS FOR THE FIRST PART OF EACH COEFFICIENT
!                                  AND N=2 IS FOR THE SECOND ONE
!
                    L=L+1
                     IF (M.EQ.1) THEN
                       IF (N.EQ.1) THEN
                         DX=-SQPR*EPR*CYPI*SZRK
                         DY=EPR/P*SYPI*SZRK
                         DZ=-EPR/R*CYPI*CZRK
                         HX=HX+A(L)*DX
                         HY=HY+A(L)*DY
                         HZ=HZ+A(L)*DZ
                                   ELSE
                         DX=DX*CPS
                         DY=DY*CPS
                         DZ=DZ*CPS
                         HX=HX+A(L)*DX
                         HY=HY+A(L)*DY
                         HZ=HZ+A(L)*DZ
                                   ENDIF
                     ELSE
                       IF (N.EQ.1) THEN
                         DX=-SPS*SQQS*EQS*CYQI*CZSK
                         DY=SPS*EQS/Q*SYQI*CZSK
                         DZ=SPS*EQS/S*CYQI*SZSK
                         HX=HX+A(L)*DX
                         HY=HY+A(L)*DY
                         HZ=HZ+A(L)*DZ
                                   ELSE
                         DX=DX*S3PS
                         DY=DY*S3PS
                         DZ=DZ*S3PS
                         HX=HX+A(L)*DX
                         HY=HY+A(L)*DY
                         HZ=HZ+A(L)*DZ
                       ENDIF
                 ENDIF
!
  4   CONTINUE
  3   CONTINUE
  2   CONTINUE
  1   CONTINUE
!
         RETURN
       END

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
       SUBROUTINE BIRK1TOT_02(PS,X,Y,Z,BX,BY,BZ)
!
!  THIS IS THE SECOND VERSION OF THE ANALYTICAL MODEL OF THE REGION 1 FIELD
!   BASED ON A SEPARATE REPRESENTATION OF THE POTENTIAL FIELD IN THE INNER AND
!   OUTER SPACE, MAPPED BY MEANS OF A SPHERO-DIPOLAR COORDINATE SYSTEM (NB #3,
!   P.91).   THE DIFFERENCE FROM THE FIRST ONE IS THAT INSTEAD OF OCTAGONAL
!   CURRENT LOOPS, CIRCULAR ONES ARE USED IN THIS VERSION FOR APPROXIMATING THE
!   FIELD IN THE OUTER REGION, WHICH IS FASTER.
!
      IMPLICIT REAL*8 (A-H,O-Z)
!
      DIMENSION D1(3,26),D2(3,79),XI(4),C1(26),C2(79)
      save

         COMMON /COORD11/ XX1(12),YY1(12)
         COMMON /RHDR/ RH,DR
         COMMON /LOOPDIP1/ TILT,XCENTRE(2),RADIUS(2), DIPX,DIPY
!
         COMMON /COORD21/ XX2(14),YY2(14),ZZ2(14)
         COMMON /DX1/ DX,SCALEIN,SCALEOUT
!
      DATA C1/-0.911582d-03,-0.376654d-02,-0.727423d-02,-0.270084d-02, &
       -0.123899d-02,-0.154387d-02,-0.340040d-02,-0.191858d-01, &
       -0.518979d-01,0.635061d-01,0.440680d0,-0.396570d0,0.561238d-02, &
        0.160938d-02,-0.451229d-02,-0.251810d-02,-0.151599d-02, &
       -0.133665d-02,-0.962089d-03,-0.272085d-01,-0.524319d-01, &
        0.717024d-01,0.523439d0,-0.405015d0,-89.5587d0,23.2806d0/

!
      DATA C2/6.04133d0,.305415d0,.606066d-02,.128379d-03,-.179406d-04, &
       1.41714d0,-27.2586d0,-4.28833d0,-1.30675d0,35.5607d0,8.95792d0,.961617d-03, &
       -.801477d-03,-.782795d-03,-1.65242d0,-16.5242d0,-5.33798d0,.424878d-03, &
       .331787d-03,-.704305d-03,.844342d-03,.953682d-04,.886271d-03, &
       25.1120d0,20.9299d0,5.14569d0,-44.1670d0,-51.0672d0,-1.87725d0,20.2998d0, &
       48.7505d0,-2.97415d0,3.35184d0,-54.2921d0,-.838712d0,-10.5123d0,70.7594d0, &
       -4.94104d0,.106166d-03,.465791d-03,-.193719d-03,10.8439d0,-29.7968d0, &
        8.08068d0,.463507d-03,-.224475d-04,.177035d-03,-.317581d-03, &
       -.264487d-03,.102075d-03,7.71390d0,10.1915d0,-4.99797d0,-23.1114d0, &
      -29.2043d0,12.2928d0,10.9542d0,33.6671d0,-9.3851d0,.174615d-03,-.789777d-06, &
       .686047d-03,.460104d-04,-.345216d-02,.221871d-02,.110078d-01, &
       -.661373d-02,.249201d-02,.343978d-01,-.193145d-05,.493963d-05, &
       -.535748d-04,.191833d-04,-.100496d-03,-.210103d-03,-.232195d-02, &
       .315335d-02,-.134320d-01,-.263222d-01/
!
      DATA TILT,XCENTRE,RADIUS,DIPX,DIPY &
      /1.00891d0,2.28397d0,-5.60831d0, &
       1.86106d0,7.83281d0,1.12541d0,0.945719d0/

      DATA DX,SCALEIN,SCALEOUT /-0.16D0,0.08D0,0.4D0/
      DATA XX1/-11.D0,2*-7.D0,2*-3.D0,3*1.D0,2*5.D0,2*9.D0/
      DATA YY1/2.D0,0.D0,4.D0,2.D0,6.D0,0.D0,4.D0,8.D0,2.D0,6.D0,0.D0, &
        4.D0/
      DATA XX2/-10.D0,-7.D0,2*-4.D0,0.D0,2*4.D0,7.D0,10.D0,5*0.D0/
      DATA YY2/3.D0,6.D0,3.D0,9.D0,6.D0,3.D0,9.D0,6.D0,3.D0,5*0.D0/
      DATA ZZ2/2*20.D0,4.D0,20.D0,2*4.D0,3*20.D0,2.D0,3.D0,4.5D0, &
        7.D0,10.D0/
!
      DATA RH,DR /9.D0,4.D0/   !  RH IS THE "HINGING DISTANCE" AND DR IS THE
!                                TRANSITION SCALE LENGTH, DEFINING THE
!                                CURVATURE  OF THE WARPING (SEE P.89, NB #2)
!
      DATA XLTDAY,XLTNGHT /78.D0,70.D0/  !  THESE ARE LATITUDES OF THE R-1 OVAL
!                                             AT NOON AND AT MIDNIGHT
      DATA DTET0 /0.034906d0/   !   THIS IS THE LATITUDINAL HALF-THICKNESS OF THE
!                                  R-1 OVAL (THE INTERPOLATION REGION BETWEEN
!                                    THE HIGH-LAT. AND THE PLASMA SHEET)
!
        TNOONN=(90.D0-XLTDAY)*0.01745329D0
        TNOONS=3.141592654D0-TNOONN     ! HERE WE ASSUME THAT THE POSITIONS OF
!                                          THE NORTHERN AND SOUTHERN R-1 OVALS
!                                          ARE SYMMETRIC IN THE SM-COORDINATES
        DTETDN=(XLTDAY-XLTNGHT)*0.01745329D0
        DR2=DR**2
!
      SPS=DSIN(PS)
      R2=X**2+Y**2+Z**2
      R=DSQRT(R2)
      R3=R*R2
!
      RMRH=R-RH
      RPRH=R+RH
      SQM=DSQRT(RMRH**2+DR2)
      SQP=DSQRT(RPRH**2+DR2)
      C=SQP-SQM
      Q=DSQRT((RH+1.D0)**2+DR2)-DSQRT((RH-1.D0)**2+DR2)
      SPSAS=SPS/R*C/Q
      CPSAS=DSQRT(1.D0-SPSAS**2)
       XAS = X*CPSAS-Z*SPSAS
       ZAS = X*SPSAS+Z*CPSAS
        IF (XAS.NE.0.D0.OR.Y.NE.0.D0) THEN
          PAS = DATAN2(Y,XAS)
                                      ELSE
          PAS=0.D0
        ENDIF
!
      TAS=DATAN2(DSQRT(XAS**2+Y**2),ZAS)
      STAS=DSIN(TAS)
      F=STAS/(STAS**6*(1.D0-R3)+R3)**0.1666666667D0
!
      TET0=DASIN(F)
      IF (TAS.GT.1.5707963D0) TET0=3.141592654D0-TET0
      DTET=DTETDN*DSIN(PAS*0.5D0)**2
      TETR1N=TNOONN+DTET
      TETR1S=TNOONS-DTET
!
! NOW LET'S DEFINE WHICH OF THE FOUR REGIONS (HIGH-LAT., NORTHERN PSBL,
!   PLASMA SHEET, SOUTHERN PSBL) DOES THE POINT (X,Y,Z) BELONG TO:
!
       IF (TET0.LT.TETR1N-DTET0.OR.TET0.GT.TETR1S+DTET0)  LOC=1 ! HIGH-LAT.
       IF (TET0.GT.TETR1N+DTET0.AND.TET0.LT.TETR1S-DTET0) LOC=2 ! PL.SHEET
       IF (TET0.GE.TETR1N-DTET0.AND.TET0.LE.TETR1N+DTET0) LOC=3 ! NORTH PSBL
       IF (TET0.GE.TETR1S-DTET0.AND.TET0.LE.TETR1S+DTET0) LOC=4 ! SOUTH PSBL
!
       IF (LOC.EQ.1) THEN   ! IN THE HIGH-LAT. REGION USE THE SUBROUTINE DIPOCT
!
!      print *, '  LOC=1 (HIGH-LAT)'    !  (test printout; disabled now)
         XI(1)=X
         XI(2)=Y
         XI(3)=Z
         XI(4)=PS
         CALL  DIPLOOP1(XI,D1)
          BX=0.D0
          BY=0.D0
          BZ=0.D0
            DO 1 I=1,26
              BX=BX+C1(I)*D1(1,I)
              BY=BY+C1(I)*D1(2,I)
  1           BZ=BZ+C1(I)*D1(3,I)
       ENDIF                                           !  END OF THE CASE 1
!
       IF (LOC.EQ.2) THEN
!           print *, '  LOC=2 (PLASMA SHEET)'  !  (test printout; disabled now)
!
         XI(1)=X
         XI(2)=Y
         XI(3)=Z
         XI(4)=PS
         CALL  CONDIP1(XI,D2)
          BX=0.D0
          BY=0.D0
          BZ=0.D0
            DO 2 I=1,79
              BX=BX+C2(I)*D2(1,I)
              BY=BY+C2(I)*D2(2,I)
  2           BZ=BZ+C2(I)*D2(3,I)
       ENDIF                                           !   END OF THE CASE 2
!
       IF (LOC.EQ.3) THEN
!       print *, '  LOC=3 (north PSBL)'  !  (test printout; disabled now)
!
         T01=TETR1N-DTET0
         T02=TETR1N+DTET0
          SQR=DSQRT(R)
          ST01AS=SQR/(R3+1.D0/DSIN(T01)**6-1.D0)**0.1666666667d0
          ST02AS=SQR/(R3+1.D0/DSIN(T02)**6-1.D0)**0.1666666667d0
          CT01AS=DSQRT(1.D0-ST01AS**2)
          CT02AS=DSQRT(1.D0-ST02AS**2)
         XAS1=R*ST01AS*DCOS(PAS)
         Y1=  R*ST01AS*DSIN(PAS)
         ZAS1=R*CT01AS
         X1=XAS1*CPSAS+ZAS1*SPSAS
         Z1=-XAS1*SPSAS+ZAS1*CPSAS ! X1,Y1,Z1 ARE COORDS OF THE NORTHERN
!                                                      BOUNDARY POINT
         XI(1)=X1
         XI(2)=Y1
         XI(3)=Z1
         XI(4)=PS
         CALL  DIPLOOP1(XI,D1)
          BX1=0.D0
          BY1=0.D0
          BZ1=0.D0
            DO 11 I=1,26
              BX1=BX1+C1(I)*D1(1,I) !   BX1,BY1,BZ1  ARE FIELD COMPONENTS
              BY1=BY1+C1(I)*D1(2,I)  !  IN THE NORTHERN BOUNDARY POINT
 11           BZ1=BZ1+C1(I)*D1(3,I)  !
!
         XAS2=R*ST02AS*DCOS(PAS)
         Y2=  R*ST02AS*DSIN(PAS)
         ZAS2=R*CT02AS
         X2=XAS2*CPSAS+ZAS2*SPSAS
         Z2=-XAS2*SPSAS+ZAS2*CPSAS ! X2,Y2,Z2 ARE COORDS OF THE SOUTHERN
!                                        BOUNDARY POINT
         XI(1)=X2
         XI(2)=Y2
         XI(3)=Z2
         XI(4)=PS
         CALL  CONDIP1(XI,D2)
          BX2=0.D0
          BY2=0.D0
          BZ2=0.D0
            DO 12 I=1,79
              BX2=BX2+C2(I)*D2(1,I)!  BX2,BY2,BZ2  ARE FIELD COMPONENTS
              BY2=BY2+C2(I)*D2(2,I) !  IN THE SOUTHERN BOUNDARY POINT
  12          BZ2=BZ2+C2(I)*D2(3,I)
!
!  NOW INTERPOLATE:
!
         SS=DSQRT((X2-X1)**2+(Y2-Y1)**2+(Z2-Z1)**2)
         DS=DSQRT((X-X1)**2+(Y-Y1)**2+(Z-Z1)**2)
         FRAC=DS/SS
         BX=BX1*(1.D0-FRAC)+BX2*FRAC
         BY=BY1*(1.D0-FRAC)+BY2*FRAC
         BZ=BZ1*(1.D0-FRAC)+BZ2*FRAC
!
        ENDIF                                              ! END OF THE CASE 3
!
        IF (LOC.EQ.4) THEN
!       print *, '  LOC=4 (south PSBL)'  !  (test printout; disabled now)
!
         T01=TETR1S-DTET0
         T02=TETR1S+DTET0
          SQR=DSQRT(R)
          ST01AS=SQR/(R3+1.D0/DSIN(T01)**6-1.D0)**0.1666666667d0
          ST02AS=SQR/(R3+1.D0/DSIN(T02)**6-1.D0)**0.1666666667d0
          CT01AS=-DSQRT(1.D0-ST01AS**2)
          CT02AS=-DSQRT(1.D0-ST02AS**2)
         XAS1=R*ST01AS*DCOS(PAS)
         Y1=  R*ST01AS*DSIN(PAS)
         ZAS1=R*CT01AS
         X1=XAS1*CPSAS+ZAS1*SPSAS
         Z1=-XAS1*SPSAS+ZAS1*CPSAS ! X1,Y1,Z1 ARE COORDS OF THE NORTHERN
!                                               BOUNDARY POINT
         XI(1)=X1
         XI(2)=Y1
         XI(3)=Z1
         XI(4)=PS
         CALL  CONDIP1(XI,D2)
          BX1=0.D0
          BY1=0.D0
          BZ1=0.D0
            DO 21 I=1,79
              BX1=BX1+C2(I)*D2(1,I) !  BX1,BY1,BZ1  ARE FIELD COMPONENTS
              BY1=BY1+C2(I)*D2(2,I)  !  IN THE NORTHERN BOUNDARY POINT
 21           BZ1=BZ1+C2(I)*D2(3,I)  !
!
         XAS2=R*ST02AS*DCOS(PAS)
         Y2=  R*ST02AS*DSIN(PAS)
         ZAS2=R*CT02AS
         X2=XAS2*CPSAS+ZAS2*SPSAS
         Z2=-XAS2*SPSAS+ZAS2*CPSAS ! X2,Y2,Z2 ARE COORDS OF THE SOUTHERN
!                                          BOUNDARY POINT
         XI(1)=X2
         XI(2)=Y2
         XI(3)=Z2
         XI(4)=PS
         CALL  DIPLOOP1(XI,D1)
          BX2=0.D0
          BY2=0.D0
          BZ2=0.D0
            DO 22 I=1,26
              BX2=BX2+C1(I)*D1(1,I) !  BX2,BY2,BZ2  ARE FIELD COMPONENTS
              BY2=BY2+C1(I)*D1(2,I) !     IN THE SOUTHERN BOUNDARY POINT
  22          BZ2=BZ2+C1(I)*D1(3,I)
!
!  NOW INTERPOLATE:
!
         SS=DSQRT((X2-X1)**2+(Y2-Y1)**2+(Z2-Z1)**2)
         DS=DSQRT((X-X1)**2+(Y-Y1)**2+(Z-Z1)**2)
         FRAC=DS/SS
         BX=BX1*(1.D0-FRAC)+BX2*FRAC
         BY=BY1*(1.D0-FRAC)+BY2*FRAC
         BZ=BZ1*(1.D0-FRAC)+BZ2*FRAC
!
        ENDIF                                        ! END OF THE CASE 4
!
!   NOW, LET US ADD THE SHIELDING FIELD
!
        CALL  BIRK1SHLD(PS,X,Y,Z,BSX,BSY,BSZ)
        BX=BX+BSX
        BY=BY+BSY
        BZ=BZ+BSZ
         RETURN
         END
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
         SUBROUTINE  DIPLOOP1(XI,D)
!
!
!      Calculates dependent model variables and their deriva-
!  tives for given independent variables and model parame-
!  ters.  Specifies model functions with free parameters which
!  must be determined by means of least squares fits (RMS
!  minimization procedure).
!
!      Description of parameters:
!
!  XI  - input vector containing independent variables;
!  D   - output double precision vector containing
!        calculated values for derivatives of dependent
!        variables with respect to LINEAR model parameters;
!
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!
!  The  26 coefficients are moments (Z- and X-components) of 12 dipoles placed
!    inside the  R1-shell,  PLUS amplitudes of two octagonal double loops.
!     The dipoles with nonzero  Yi appear in pairs with equal moments.
!                  (see the notebook #2, pp.102-103, for details)
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!
         IMPLICIT  REAL * 8  (A - H, O - Z)
!
         COMMON /COORD11/ XX(12),YY(12)
         COMMON /LOOPDIP1/ TILT,XCENTRE(2),RADIUS(2),  DIPX,DIPY
         COMMON /RHDR/RH,DR
         DIMENSION XI(4),D(3,26)
      save
!
           X = XI(1)
         Y = XI(2)
         Z = XI(3)
           PS= XI(4)
           SPS=DSIN(PS)
!
         DO 1 I=1,12
           R2=(XX(I)*DIPX)**2+(YY(I)*DIPY)**2
           R=DSQRT(R2)
             RMRH=R-RH
             RPRH=R+RH
             DR2=DR**2
             SQM=DSQRT(RMRH**2+DR2)
             SQP=DSQRT(RPRH**2+DR2)
             C=SQP-SQM
             Q=DSQRT((RH+1.D0)**2+DR2)-DSQRT((RH-1.D0)**2+DR2)
             SPSAS=SPS/R*C/Q
             CPSAS=DSQRT(1.D0-SPSAS**2)
         XD= (XX(I)*DIPX)*CPSAS
         YD= (YY(I)*DIPY)
         ZD=-(XX(I)*DIPX)*SPSAS
      CALL DIPXYZ(X-XD,Y-YD,Z-ZD,BX1X,BY1X,BZ1X,BX1Y,BY1Y,BZ1Y, &
        BX1Z,BY1Z,BZ1Z)
        IF (DABS(YD).GT.1.D-10) THEN
      CALL DIPXYZ(X-XD,Y+YD,Z-ZD,BX2X,BY2X,BZ2X,BX2Y,BY2Y,BZ2Y, &
        BX2Z,BY2Z,BZ2Z)
                                   ELSE
        BX2X=0.D0
        BY2X=0.D0
        BZ2X=0.D0
!
        BX2Z=0.D0
        BY2Z=0.D0
        BZ2Z=0.D0
                                   ENDIF
!
            D(1,I)=BX1Z+BX2Z
            D(2,I)=BY1Z+BY2Z
            D(3,I)=BZ1Z+BZ2Z
            D(1,I+12)=(BX1X+BX2X)*SPS
            D(2,I+12)=(BY1X+BY2X)*SPS
            D(3,I+12)=(BZ1X+BZ2X)*SPS
  1   CONTINUE
!
           R2=(XCENTRE(1)+RADIUS(1))**2
           R=DSQRT(R2)
             RMRH=R-RH
             RPRH=R+RH
             DR2=DR**2
             SQM=DSQRT(RMRH**2+DR2)
             SQP=DSQRT(RPRH**2+DR2)
             C=SQP-SQM
             Q=DSQRT((RH+1.D0)**2+DR2)-DSQRT((RH-1.D0)**2+DR2)
             SPSAS=SPS/R*C/Q
             CPSAS=DSQRT(1.D0-SPSAS**2)
         XOCT1= X*CPSAS-Z*SPSAS
         YOCT1= Y
         ZOCT1= X*SPSAS+Z*CPSAS
!
      CALL CROSSLP(XOCT1,YOCT1,ZOCT1,BXOCT1,BYOCT1,BZOCT1,XCENTRE(1), &
              RADIUS(1),TILT)
            D(1,25)=BXOCT1*CPSAS+BZOCT1*SPSAS
            D(2,25)=BYOCT1
            D(3,25)=-BXOCT1*SPSAS+BZOCT1*CPSAS
!
           R2=(RADIUS(2)-XCENTRE(2))**2
           R=DSQRT(R2)
             RMRH=R-RH
             RPRH=R+RH
             DR2=DR**2
             SQM=DSQRT(RMRH**2+DR2)
             SQP=DSQRT(RPRH**2+DR2)
             C=SQP-SQM
             Q=DSQRT((RH+1.D0)**2+DR2)-DSQRT((RH-1.D0)**2+DR2)
             SPSAS=SPS/R*C/Q
             CPSAS=DSQRT(1.D0-SPSAS**2)
         XOCT2= X*CPSAS-Z*SPSAS -XCENTRE(2)
         YOCT2= Y
         ZOCT2= X*SPSAS+Z*CPSAS
            CALL CIRCLE(XOCT2,YOCT2,ZOCT2,RADIUS(2),BX,BY,BZ)
            D(1,26) =  BX*CPSAS+BZ*SPSAS
            D(2,26) =  BY
            D(3,26) = -BX*SPSAS+BZ*CPSAS
!
            RETURN
            END
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

        SUBROUTINE CIRCLE(X,Y,Z,RL,BX,BY,BZ)
!
!  RETURNS COMPONENTS OF THE FIELD FROM A CIRCULAR CURRENT LOOP OF RADIUS RL
!  USES THE SECOND (MORE ACCURATE) APPROXIMATION GIVEN IN ABRAMOWITZ AND STEGUN

        IMPLICIT REAL*8 (A-H,O-Z)
        REAL*8 K
        DATA PI/3.141592654D0/
      save
!
        RHO2=X*X+Y*Y
        RHO=DSQRT(RHO2)
        R22=Z*Z+(RHO+RL)**2
        R2=DSQRT(R22)
        R12=R22-4.D0*RHO*RL
        R32=0.5D0*(R12+R22)
        XK2=1.D0-R12/R22
        XK2S=1.D0-XK2
        DL=DLOG(1.D0/XK2S)
        K=1.38629436112d0+XK2S*(0.09666344259D0+XK2S*(0.03590092383d0+ &
           XK2S*(0.03742563713d0+XK2S*0.01451196212d0))) +DL* &
           (0.5D0+XK2S*(0.12498593597D0+XK2S*(0.06880248576D0+ &
           XK2S*(0.03328355346D0+XK2S*0.00441787012D0))))
        E=1.D0+XK2S*(0.44325141463D0+XK2S*(0.0626060122D0+XK2S* &
            (0.04757383546D0+XK2S*0.01736506451D0))) +DL* &
           XK2S*(0.2499836831D0+XK2S*(0.09200180037D0+XK2S* &
             (0.04069697526D0+XK2S*0.00526449639D0)))

        IF (RHO.GT.1.D-6) THEN
           BRHO=Z/(RHO2*R2)*(R32/R12*E-K) !  THIS IS NOT EXACTLY THE B-RHO COM-
                           ELSE           !   PONENT - NOTE THE ADDITIONAL
           BRHO=PI*RL/R2*(RL-RHO)/R12*Z/(R32-RHO2)  !      DIVISION BY RHO
        ENDIF

        BX=BRHO*X
        BY=BRHO*Y
        BZ=(K-E*(R32-2.D0*RL*RL)/R12)/R2
        RETURN
        END
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

        SUBROUTINE CROSSLP(X,Y,Z,BX,BY,BZ,XC,RL,AL)
!
!   RETURNS FIELD COMPONENTS OF A PAIR OF LOOPS WITH A COMMON CENTER AND
!    DIAMETER,  COINCIDING WITH THE X AXIS. THE LOOPS ARE INCLINED TO THE
!    EQUATORIAL PLANE BY THE ANGLE AL (RADIANS) AND SHIFTED IN THE POSITIVE
!     X-DIRECTION BY THE DISTANCE  XC.
!
        IMPLICIT REAL*8 (A-H,O-Z)
      save
!
            CAL=DCOS(AL)
            SAL=DSIN(AL)
!
        Y1=Y*CAL-Z*SAL
        Z1=Y*SAL+Z*CAL
        Y2=Y*CAL+Z*SAL
        Z2=-Y*SAL+Z*CAL
        CALL CIRCLE(X-XC,Y1,Z1,RL,BX1,BY1,BZ1)
        CALL CIRCLE(X-XC,Y2,Z2,RL,BX2,BY2,BZ2)
        BX=BX1+BX2
        BY= (BY1+BY2)*CAL+(BZ1-BZ2)*SAL
        BZ=-(BY1-BY2)*SAL+(BZ1+BZ2)*CAL
!
        RETURN
        END

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

       SUBROUTINE DIPXYZ(X,Y,Z,BXX,BYX,BZX,BXY,BYY,BZY,BXZ,BYZ,BZZ)
!
!       RETURNS THE FIELD COMPONENTS PRODUCED BY THREE DIPOLES, EACH
!        HAVING M=Me AND ORIENTED PARALLEL TO X,Y, and Z AXIS, RESP.
!
      IMPLICIT REAL*8 (A-H,O-Z)
      save
!
      X2=X**2
      Y2=Y**2
      Z2=Z**2
      R2=X2+Y2+Z2

      XMR5=30574.D0/(R2*R2*DSQRT(R2))
      XMR53=3.D0*XMR5
      BXX=XMR5*(3.D0*X2-R2)
      BYX=XMR53*X*Y
      BZX=XMR53*X*Z
!
      BXY=BYX
      BYY=XMR5*(3.D0*Y2-R2)
      BZY=XMR53*Y*Z
!
      BXZ=BZX
      BYZ=BZY
      BZZ=XMR5*(3.D0*Z2-R2)
!
      RETURN
      END
!
!------------------------------------------------------------------------------
         SUBROUTINE  CONDIP1(XI,D)
!
!      Calculates dependent model variables and their derivatives for given
!  independent variables and model parameters.  Specifies model functions with
!  free parameters which must be determined by means of least squares fits
!  (RMS minimization procedure).
!
!      Description of parameters:
!
!  XI  - input vector containing independent variables;
!  D   - output double precision vector containing
!        calculated values for derivatives of dependent
!        variables with respect to LINEAR model parameters;
!
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!
!  The  79 coefficients are (1) 5 amplitudes of the conical harmonics, plus
!                           (2) (9x3+5x2)x2=74 components of the dipole moments
!              (see the notebook #2, pp.113-..., for details)
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!
         IMPLICIT  REAL * 8  (A - H, O - Z)
!
      COMMON /DX1/ DX,SCALEIN,SCALEOUT
      COMMON /COORD21/ XX(14),YY(14),ZZ(14)
!
         DIMENSION XI(4),D(3,79),CF(5),SF(5)
      save
!
           X = XI(1)
         Y = XI(2)
         Z = XI(3)
           PS= XI(4)
           SPS=DSIN(PS)
           CPS=DCOS(PS)
!
      XSM=X*CPS-Z*SPS  - DX
      ZSM=Z*CPS+X*SPS
      RO2=XSM**2+Y**2
      RO=SQRT(RO2)
!
      CF(1)=XSM/RO
      SF(1)=Y/RO
!
      CF(2)=CF(1)**2-SF(1)**2
      SF(2)=2.d0*SF(1)*CF(1)
      CF(3)=CF(2)*CF(1)-SF(2)*SF(1)
      SF(3)=SF(2)*CF(1)+CF(2)*SF(1)
      CF(4)=CF(3)*CF(1)-SF(3)*SF(1)
      SF(4)=SF(3)*CF(1)+CF(3)*SF(1)
      CF(5)=CF(4)*CF(1)-SF(4)*SF(1)
      SF(5)=SF(4)*CF(1)+CF(4)*SF(1)
!
      R2=RO2+ZSM**2
      R=DSQRT(R2)
      C=ZSM/R
      S=RO/R
      CH=DSQRT(0.5D0*(1.D0+C))
      SH=DSQRT(0.5D0*(1.D0-C))
      TNH=SH/CH
      CNH=1.D0/TNH
!
      DO 1 M=1,5
       BT=dble(M)*CF(M)/(R*S)*(TNH**M+CNH**M)
       BF=-0.5D0*dble(M)*SF(M)/R*(TNH**(M-1)/CH**2-CNH**(M-1)/SH**2)
       BXSM=BT*C*CF(1)-BF*SF(1)
       BY=BT*C*SF(1)+BF*CF(1)
       BZSM=-BT*S
!
       D(1,M)=BXSM*CPS+BZSM*SPS
       D(2,M)=BY
  1    D(3,M)=-BXSM*SPS+BZSM*CPS
!
      XSM = X*CPS-Z*SPS
      ZSM = Z*CPS+X*SPS
!
        DO 2 I=1,9
!
        IF (I.EQ.3.OR.I.EQ.5.OR.I.EQ.6) THEN
                XD =  XX(I)*SCALEIN
                YD =  YY(I)*SCALEIN
                                         ELSE
                XD =  XX(I)*SCALEOUT
                YD =  YY(I)*SCALEOUT
        ENDIF
!
         ZD =  ZZ(I)
!
      CALL DIPXYZ(XSM-XD,Y-YD,ZSM-ZD,BX1X,BY1X,BZ1X,BX1Y,BY1Y,BZ1Y, &
        BX1Z,BY1Z,BZ1Z)
      CALL DIPXYZ(XSM-XD,Y+YD,ZSM-ZD,BX2X,BY2X,BZ2X,BX2Y,BY2Y,BZ2Y, &
        BX2Z,BY2Z,BZ2Z)
      CALL DIPXYZ(XSM-XD,Y-YD,ZSM+ZD,BX3X,BY3X,BZ3X,BX3Y,BY3Y,BZ3Y, &
        BX3Z,BY3Z,BZ3Z)
      CALL DIPXYZ(XSM-XD,Y+YD,ZSM+ZD,BX4X,BY4X,BZ4X,BX4Y,BY4Y,BZ4Y, &
        BX4Z,BY4Z,BZ4Z)
!
      IX=I*3+3
      IY=IX+1
      IZ=IY+1
!
      D(1,IX)=(BX1X+BX2X-BX3X-BX4X)*CPS+(BZ1X+BZ2X-BZ3X-BZ4X)*SPS
      D(2,IX)= BY1X+BY2X-BY3X-BY4X
      D(3,IX)=(BZ1X+BZ2X-BZ3X-BZ4X)*CPS-(BX1X+BX2X-BX3X-BX4X)*SPS
!
      D(1,IY)=(BX1Y-BX2Y-BX3Y+BX4Y)*CPS+(BZ1Y-BZ2Y-BZ3Y+BZ4Y)*SPS
      D(2,IY)= BY1Y-BY2Y-BY3Y+BY4Y
      D(3,IY)=(BZ1Y-BZ2Y-BZ3Y+BZ4Y)*CPS-(BX1Y-BX2Y-BX3Y+BX4Y)*SPS
!
      D(1,IZ)=(BX1Z+BX2Z+BX3Z+BX4Z)*CPS+(BZ1Z+BZ2Z+BZ3Z+BZ4Z)*SPS
      D(2,IZ)= BY1Z+BY2Z+BY3Z+BY4Z
      D(3,IZ)=(BZ1Z+BZ2Z+BZ3Z+BZ4Z)*CPS-(BX1Z+BX2Z+BX3Z+BX4Z)*SPS
!
      IX=IX+27
      IY=IY+27
      IZ=IZ+27
!
      D(1,IX)=SPS*((BX1X+BX2X+BX3X+BX4X)*CPS+(BZ1X+BZ2X+BZ3X+BZ4X)*SPS)
      D(2,IX)=SPS*(BY1X+BY2X+BY3X+BY4X)
      D(3,IX)=SPS*((BZ1X+BZ2X+BZ3X+BZ4X)*CPS-(BX1X+BX2X+BX3X+BX4X)*SPS)
!
      D(1,IY)=SPS*((BX1Y-BX2Y+BX3Y-BX4Y)*CPS+(BZ1Y-BZ2Y+BZ3Y-BZ4Y)*SPS)
      D(2,IY)=SPS*(BY1Y-BY2Y+BY3Y-BY4Y)
      D(3,IY)=SPS*((BZ1Y-BZ2Y+BZ3Y-BZ4Y)*CPS-(BX1Y-BX2Y+BX3Y-BX4Y)*SPS)
!
      D(1,IZ)=SPS*((BX1Z+BX2Z-BX3Z-BX4Z)*CPS+(BZ1Z+BZ2Z-BZ3Z-BZ4Z)*SPS)
      D(2,IZ)=SPS*(BY1Z+BY2Z-BY3Z-BY4Z)
      D(3,IZ)=SPS*((BZ1Z+BZ2Z-BZ3Z-BZ4Z)*CPS-(BX1Z+BX2Z-BX3Z-BX4Z)*SPS)
  2   CONTINUE
!
      DO 3 I=1,5
      ZD=ZZ(I+9)
      CALL DIPXYZ(XSM,Y,ZSM-ZD,BX1X,BY1X,BZ1X,BX1Y,BY1Y,BZ1Y,BX1Z,BY1Z, &
        BZ1Z)
      CALL DIPXYZ(XSM,Y,ZSM+ZD,BX2X,BY2X,BZ2X,BX2Y,BY2Y,BZ2Y,BX2Z,BY2Z, &
        BZ2Z)
       IX=58+I*2
       IZ=IX+1
      D(1,IX)=(BX1X-BX2X)*CPS+(BZ1X-BZ2X)*SPS
      D(2,IX)=BY1X-BY2X
      D(3,IX)=(BZ1X-BZ2X)*CPS-(BX1X-BX2X)*SPS
!
      D(1,IZ)=(BX1Z+BX2Z)*CPS+(BZ1Z+BZ2Z)*SPS
      D(2,IZ)=BY1Z+BY2Z
      D(3,IZ)=(BZ1Z+BZ2Z)*CPS-(BX1Z+BX2Z)*SPS
!
      IX=IX+10
      IZ=IZ+10
      D(1,IX)=SPS*((BX1X+BX2X)*CPS+(BZ1X+BZ2X)*SPS)
      D(2,IX)=SPS*(BY1X+BY2X)
      D(3,IX)=SPS*((BZ1X+BZ2X)*CPS-(BX1X+BX2X)*SPS)
!
      D(1,IZ)=SPS*((BX1Z-BX2Z)*CPS+(BZ1Z-BZ2Z)*SPS)
      D(2,IZ)=SPS*(BY1Z-BY2Z)
  3   D(3,IZ)=SPS*((BZ1Z-BZ2Z)*CPS-(BX1Z-BX2Z)*SPS)
!
            RETURN
            END
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
         SUBROUTINE  BIRK1SHLD(PS,X,Y,Z,BX,BY,BZ)
!
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!
!  The 64 linear parameters are amplitudes of the "box" harmonics.
! The 16 nonlinear parameters are the scales Pi, and Qk entering the arguments
!  of sines/cosines and exponents in each of  32 cartesian harmonics
!  N.A. Tsyganenko, Spring 1994, adjusted for the Birkeland field Aug.22, 1995
!    Revised  June 12, 1996.
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!
      IMPLICIT  REAL * 8  (A - H, O - Z)
!
      DIMENSION A(80)
      DIMENSION P1(4),R1(4),Q1(4),S1(4),RP(4),RR(4),RQ(4),RS(4)
      save
!
      EQUIVALENCE (P1(1),A(65)),(R1(1),A(69)),(Q1(1),A(73)), &
       (S1(1),A(77))
!
      DATA A/1.174198045d0,-1.463820502d0,4.840161537d0,-3.674506864d0, &
       82.18368896d0,-94.94071588d0,-4122.331796d0,4670.278676d0,-21.54975037d0, &
       26.72661293d0,-72.81365728d0,44.09887902d0,40.08073706d0,-51.23563510d0, &
       1955.348537d0,-1940.971550d0,794.0496433d0,-982.2441344d0,1889.837171d0, &
       -558.9779727d0,-1260.543238d0,1260.063802d0,-293.5942373d0,344.7250789d0, &
       -773.7002492d0,957.0094135d0,-1824.143669d0,520.7994379d0,1192.484774d0, &
       -1192.184565d0,89.15537624d0,-98.52042999d0,-0.8168777675d-01, &
       0.4255969908d-01,0.3155237661d0,-0.3841755213d0,2.494553332d0, &
       -0.6571440817d-01,-2.765661310d0,0.4331001908d0,0.1099181537d0, &
       -0.6154126980d-01,-0.3258649260d0,0.6698439193d0,-5.542735524d0, &
       0.1604203535d0,5.854456934d0,-0.8323632049d0,3.732608869d0,-3.130002153d0, &
       107.0972607d0,-32.28483411d0,-115.2389298d0,54.45064360d0,-0.5826853320d0, &
       -3.582482231d0,-4.046544561d0,3.311978102d0,-104.0839563d0,30.26401293d0, &
       97.29109008d0,-50.62370872d0,-296.3734955d0,127.7872523d0,5.303648988d0, &
       10.40368955d0,69.65230348d0,466.5099509d0,1.645049286d0,3.825838190d0, &
       11.66675599d0,558.9781177d0,1.826531343d0,2.066018073d0,25.40971369d0, &
       990.2795225d0,2.319489258d0,4.555148484d0,9.691185703d0,591.8280358d0/
!
         BX=0.D0
         BY=0.D0
         BZ=0.D0
         CPS=DCOS(PS)
         SPS=DSIN(PS)
         S3PS=4.D0*CPS**2-1.D0
! jah, foresys : Variable HX,HY,HZ may not have been  initialized
         data HX,HY,HZ /0.d0,0.d0,0.d0/
!
         DO 11 I=1,4
          RP(I)=1.D0/P1(I)
          RR(I)=1.D0/R1(I)
          RQ(I)=1.D0/Q1(I)
 11       RS(I)=1.D0/S1(I)
!
          L=0
!
           DO 1 M=1,2     !    M=1 IS FOR THE 1ST SUM ("PERP." SYMMETRY)
!                           AND M=2 IS FOR THE SECOND SUM ("PARALL." SYMMETRY)
             DO 2 I=1,4
                  CYPI=DCOS(Y*RP(I))
                  CYQI=DCOS(Y*RQ(I))
                  SYPI=DSIN(Y*RP(I))
                  SYQI=DSIN(Y*RQ(I))
!
                DO 3 K=1,4
                   SZRK=DSIN(Z*RR(K))
                   CZSK=DCOS(Z*RS(K))
                   CZRK=DCOS(Z*RR(K))
                   SZSK=DSIN(Z*RS(K))
                     SQPR=DSQRT(RP(I)**2+RR(K)**2)
                     SQQS=DSQRT(RQ(I)**2+RS(K)**2)
                        EPR=DEXP(X*SQPR)
                        EQS=DEXP(X*SQQS)
!
                    DO 4 N=1,2  ! N=1 IS FOR THE FIRST PART OF EACH COEFFICIENT
!                                  AND N=2 IS FOR THE SECOND ONE
                     IF (M.EQ.1) THEN
                       IF (N.EQ.1) THEN
                         HX=-SQPR*EPR*CYPI*SZRK
                         HY=RP(I)*EPR*SYPI*SZRK
                         HZ=-RR(K)*EPR*CYPI*CZRK
                                   ELSE
                         HX=HX*CPS
                         HY=HY*CPS
                         HZ=HZ*CPS
                                   ENDIF
                     ELSE
                       IF (N.EQ.1) THEN
                         HX=-SPS*SQQS*EQS*CYQI*CZSK
                         HY=SPS*RQ(I)*EQS*SYQI*CZSK
                         HZ=SPS*RS(K)*EQS*CYQI*SZSK
                                   ELSE
                         HX=HX*S3PS
                         HY=HY*S3PS
                         HZ=HZ*S3PS
                       ENDIF
                 ENDIF
       L=L+1
!
       BX=BX+A(L)*HX
       BY=BY+A(L)*HY
  4    BZ=BZ+A(L)*HZ
  3   CONTINUE
  2   CONTINUE
  1   CONTINUE
!
         RETURN
       END
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
         SUBROUTINE BIRK2TOT_02(PS,X,Y,Z,BX,BY,BZ)
!
          IMPLICIT REAL*8 (A-H,O-Z)
      save
!
          CALL BIRK2SHL(X,Y,Z,PS,WX,WY,WZ)
          CALL R2_BIRK(X,Y,Z,PS,HX,HY,HZ)
         BX=WX+HX
         BY=WY+HY
         BZ=WZ+HZ
         RETURN
         END
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
! THIS CODE IS FOR THE FIELD FROM  2x2x2=8 "CARTESIAN" HARMONICS
!
         SUBROUTINE  BIRK2SHL(X,Y,Z,PS,HX,HY,HZ)
!
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!    The model parameters are provided to this module via common-block /A/.
!  The 16 linear parameters enter in pairs in the amplitudes of the
!       "cartesian" harmonics.
!    The 8 nonlinear parameters are the scales Pi,Ri,Qi,and Si entering the
!  arguments of exponents, sines, and cosines in each of the 8 "Cartesian"
!   harmonics
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!
       IMPLICIT  REAL * 8  (A - H, O - Z)
!
         DIMENSION P(2),R(2),Q(2),S(2)
         DIMENSION A(24)
      save
!
         EQUIVALENCE(P(1),A(17)),(R(1),A(19)),(Q(1),A(21)),(S(1),A(23))
         DATA A/-111.6371348d0,124.5402702d0,110.3735178d0,-122.0095905d0, &
       111.9448247d0,-129.1957743d0,-110.7586562d0,126.5649012d0,-0.7865034384d0, &
       -0.2483462721d0,0.8026023894d0,0.2531397188d0,10.72890902d0,0.8483902118d0, &
       -10.96884315d0,-0.8583297219d0,13.85650567d0,14.90554500d0,10.21914434d0, &
       10.09021632d0,6.340382460d0,14.40432686d0,12.71023437d0,12.83966657d0/
!
            CPS=DCOS(PS)
            SPS=DSIN(PS)
            S3PS=4.D0*CPS**2-1.D0   !  THIS IS SIN(3*PS)/SIN(PS)
!
           HX=0.D0
           HY=0.D0
           HZ=0.D0
           L=0
! jah, foresys : Variable DX,DY,DZ may not have been  initialized
           data DX,DY,DZ /0.d0,0.d0,0.d0/
!
           DO 1 M=1,2     !    M=1 IS FOR THE 1ST SUM ("PERP." SYMMETRY)
!                           AND M=2 IS FOR THE SECOND SUM ("PARALL." SYMMETRY)
             DO 2 I=1,2
                  CYPI=DCOS(Y/P(I))
                  CYQI=DCOS(Y/Q(I))
                  SYPI=DSIN(Y/P(I))
                  SYQI=DSIN(Y/Q(I))
!
               DO 3 K=1,2
                   SZRK=DSIN(Z/R(K))
                   CZSK=DCOS(Z/S(K))
                   CZRK=DCOS(Z/R(K))
                   SZSK=DSIN(Z/S(K))
                     SQPR=DSQRT(1.D0/P(I)**2+1.D0/R(K)**2)
                     SQQS=DSQRT(1.D0/Q(I)**2+1.D0/S(K)**2)
                        EPR=DEXP(X*SQPR)
                        EQS=DEXP(X*SQQS)
!
                   DO 4 N=1,2  ! N=1 IS FOR THE FIRST PART OF EACH COEFFICIENT
!                                  AND N=2 IS FOR THE SECOND ONE
!
                    L=L+1
                     IF (M.EQ.1) THEN
                       IF (N.EQ.1) THEN
                         DX=-SQPR*EPR*CYPI*SZRK
                         DY=EPR/P(I)*SYPI*SZRK
                         DZ=-EPR/R(K)*CYPI*CZRK
                         HX=HX+A(L)*DX
                         HY=HY+A(L)*DY
                         HZ=HZ+A(L)*DZ
                                   ELSE
                         DX=DX*CPS
                         DY=DY*CPS
                         DZ=DZ*CPS
                         HX=HX+A(L)*DX
                         HY=HY+A(L)*DY
                         HZ=HZ+A(L)*DZ
                                   ENDIF
                     ELSE
                       IF (N.EQ.1) THEN
                         DX=-SPS*SQQS*EQS*CYQI*CZSK
                         DY=SPS*EQS/Q(I)*SYQI*CZSK
                         DZ=SPS*EQS/S(K)*CYQI*SZSK
                         HX=HX+A(L)*DX
                         HY=HY+A(L)*DY
                         HZ=HZ+A(L)*DZ
                                   ELSE
                         DX=DX*S3PS
                         DY=DY*S3PS
                         DZ=DZ*S3PS
                         HX=HX+A(L)*DX
                         HY=HY+A(L)*DY
                         HZ=HZ+A(L)*DZ
                       ENDIF
                 ENDIF
!
  4   CONTINUE
  3   CONTINUE
  2   CONTINUE
  1   CONTINUE
!
         RETURN
       END

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
       SUBROUTINE R2_BIRK(X,Y,Z,PS,BX,BY,BZ)
!
!  RETURNS THE MODEL FIELD FOR THE REGION 2 BIRKELAND CURRENT/PARTIAL RC
!    (WITHOUT SHIELDING FIELD)
!
       IMPLICIT REAL*8 (A-H,O-Z)
      save
!      SAVE PSI,CPS,SPS
       DATA DELARG/0.030D0/,DELARG1/0.015D0/,PSI/10.D0/
!
       IF (DABS(PSI-PS).GT.1.D-10) THEN
         PSI=PS
         CPS=DCOS(PS)
         SPS=DSIN(PS)
       ENDIF
!
       XSM=X*CPS-Z*SPS
       ZSM=Z*CPS+X*SPS
!
       XKS=XKSI(XSM,Y,ZSM)
      IF (XKS.LT.-(DELARG+DELARG1)) THEN
        CALL R2OUTER(XSM,Y,ZSM,BXSM,BY,BZSM)
         BXSM=-BXSM*0.02d0      !  ALL COMPONENTS ARE MULTIPLIED BY THE
         BY=-BY*0.02d0          !  FACTOR -0.02, IN ORDER TO NORMALIZE THE
         BZSM=-BZSM*0.02d0      !  FIELD (SO THAT Bz=-1 nT at X=-5.3 RE, Y=Z=0)
      ENDIF
      IF (XKS.GE.-(DELARG+DELARG1).AND.XKS.LT.-DELARG+DELARG1) THEN
        CALL R2OUTER(XSM,Y,ZSM,BXSM1,BY1,BZSM1)
        CALL R2SHEET(XSM,Y,ZSM,BXSM2,BY2,BZSM2)
        F2=-0.02d0*TKSI(XKS,-DELARG,DELARG1)
        F1=-0.02d0 -F2
        BXSM=BXSM1*F1+BXSM2*F2
        BY=BY1*F1+BY2*F2
        BZSM=BZSM1*F1+BZSM2*F2
      ENDIF

      IF (XKS.GE.-DELARG+DELARG1.AND.XKS.LT.DELARG-DELARG1) THEN
       CALL R2SHEET(XSM,Y,ZSM,BXSM,BY,BZSM)
         BXSM=-BXSM*0.02d0
         BY=-BY*0.02d0
         BZSM=-BZSM*0.02d0
      ENDIF
      IF (XKS.GE.DELARG-DELARG1.AND.XKS.LT.DELARG+DELARG1) THEN
        CALL R2INNER(XSM,Y,ZSM,BXSM1,BY1,BZSM1)
        CALL R2SHEET(XSM,Y,ZSM,BXSM2,BY2,BZSM2)
        F1=-0.02d0*TKSI(XKS,DELARG,DELARG1)
        F2=-0.02d0 -F1
        BXSM=BXSM1*F1+BXSM2*F2
        BY=BY1*F1+BY2*F2
        BZSM=BZSM1*F1+BZSM2*F2
      ENDIF
      IF (XKS.GE.DELARG+DELARG1) THEN
         CALL R2INNER(XSM,Y,ZSM,BXSM,BY,BZSM)
         BXSM=-BXSM*0.02d0
         BY=-BY*0.02d0
         BZSM=-BZSM*0.02d0
      ENDIF
!
        BX=BXSM*CPS+BZSM*SPS
        BZ=BZSM*CPS-BXSM*SPS
!
        RETURN
        END
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
      SUBROUTINE R2INNER (X,Y,Z,BX,BY,BZ)
!
!
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION CBX(5),CBY(5),CBZ(5)
      save
!
      DATA PL1,PL2,PL3,PL4,PL5,PL6,PL7,PL8 &
      /154.185d0,-2.12446d0,.601735d-01, &
       -.153954d-02,.355077d-04,29.9996d0,262.886d0,99.9132d0/

      DATA PN1,PN2,PN3,PN4,PN5,PN6,PN7,PN8 &
      /-8.1902d0,6.5239d0,5.504d0,7.7815d0, &
       .8573d0,3.0986d0,.0774d0,-.038d0/
!
      CALL BCONIC(X,Y,Z,CBX,CBY,CBZ,5)
!
!   NOW INTRODUCE  ONE  4-LOOP SYSTEM:
!
       CALL LOOPS4(X,Y,Z,DBX8,DBY8,DBZ8,PN1,PN2,PN3,PN4,PN5,PN6)
!
       CALL DIPDISTR(X-PN7,Y,Z,DBX6,DBY6,DBZ6,0)
       CALL DIPDISTR(X-PN8,Y,Z,DBX7,DBY7,DBZ7,1)

!                           NOW COMPUTE THE FIELD COMPONENTS:

      BX=PL1*CBX(1)+PL2*CBX(2)+PL3*CBX(3)+PL4*CBX(4)+PL5*CBX(5) &
       +PL6*DBX6+PL7*DBX7+PL8*DBX8
      BY=PL1*CBY(1)+PL2*CBY(2)+PL3*CBY(3)+PL4*CBY(4)+PL5*CBY(5) &
       +PL6*DBY6+PL7*DBY7+PL8*DBY8
      BZ=PL1*CBZ(1)+PL2*CBZ(2)+PL3*CBZ(3)+PL4*CBZ(4)+PL5*CBZ(5) &
       +PL6*DBZ6+PL7*DBZ7+PL8*DBZ8
!
      RETURN
      END

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

      SUBROUTINE BCONIC(X,Y,Z,CBX,CBY,CBZ,NMAX)
!
!   "CONICAL" HARMONICS
!
       IMPLICIT REAL*8 (A-H,O-Z)
!
       DIMENSION CBX(NMAX),CBY(NMAX),CBZ(NMAX)
      save

       RO2=X**2+Y**2
       RO=SQRT(RO2)
!
       CF=X/RO
       SF=Y/RO
       CFM1=1.D0
       SFM1=0.D0
!
      R2=RO2+Z**2
      R=DSQRT(R2)
      C=Z/R
      S=RO/R
      CH=DSQRT(0.5D0*(1.D0+C))
      SH=DSQRT(0.5D0*(1.D0-C))
      TNHM1=1.D0
      CNHM1=1.D0
      TNH=SH/CH
      CNH=1.D0/TNH
!
      DO 1 M=1,NMAX
        CFM=CFM1*CF-SFM1*SF
        SFM=CFM1*SF+SFM1*CF
        CFM1=CFM
        SFM1=SFM
        TNHM=TNHM1*TNH
        CNHM=CNHM1*CNH
       BT=dble(M)*CFM/(R*S)*(TNHM+CNHM)
       BF=-0.5D0*dble(M)*SFM/R*(TNHM1/CH**2-CNHM1/SH**2)
         TNHM1=TNHM
         CNHM1=CNHM
       CBX(M)=BT*C*CF-BF*SF
       CBY(M)=BT*C*SF+BF*CF
  1    CBZ(M)=-BT*S
!
       RETURN
       END

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

       SUBROUTINE DIPDISTR(X,Y,Z,BX,BY,BZ,MODE)
!
!   RETURNS FIELD COMPONENTS FROM A LINEAR DISTRIBUTION OF DIPOLAR SOURCES
!     ON THE Z-AXIS.  THE PARAMETER MODE DEFINES HOW THE DIPOLE STRENGTH
!     VARIES ALONG THE Z-AXIS:  MODE=0 IS FOR A STEP-FUNCTION (Mx=const > 0
!         FOR Z > 0, AND Mx=-const < 0 FOR Z < 0)
!      WHILE MODE=1 IS FOR A LINEAR VARIATION OF THE DIPOLE MOMENT DENSITY
!       SEE NB#3, PAGE 53 FOR DETAILS.
!
!
! INPUT: X,Y,Z OF A POINT OF SPACE, AND MODE
!

        IMPLICIT REAL*8 (A-H,O-Z)
      save
        X2=X*X
        RHO2=X2+Y*Y
        R2=RHO2+Z*Z
        R3=R2*DSQRT(R2)

        IF (MODE.EQ.0) THEN
         BX=Z/RHO2**2*(R2*(Y*Y-X2)-RHO2*X2)/R3
         BY=-X*Y*Z/RHO2**2*(2.D0*R2+RHO2)/R3
         BZ=X/R3
        ELSE
         BX=Z/RHO2**2*(Y*Y-X2)
         BY=-2.D0*X*Y*Z/RHO2**2
         BZ=X/RHO2
        ENDIF
         RETURN
         END

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
      SUBROUTINE R2OUTER (X,Y,Z,BX,BY,BZ)
!
      IMPLICIT REAL*8 (A-H,O-Z)
      save
!
      DATA PL1,PL2,PL3,PL4,PL5 &
     /-34.105d0,-2.00019d0,628.639d0,73.4847d0,12.5162d0/

      DATA PN1,PN2,PN3,PN4,PN5,PN6,PN7,PN8,PN9,PN10,PN11,PN12,PN13,PN14, &
        PN15,PN16,PN17 &
       /.55d0,.694d0,.0031d0,1.55d0,2.8d0,.1375d0,-.7d0,.2d0,.9625d0, &
       -2.994d0,2.925d0,-1.775d0,4.3d0,-.275d0,2.7d0,.4312d0,1.55d0/
!
!    THREE PAIRS OF CROSSED LOOPS:
!
      CALL CROSSLP(X,Y,Z,DBX1,DBY1,DBZ1,PN1,PN2,PN3)
      CALL CROSSLP(X,Y,Z,DBX2,DBY2,DBZ2,PN4,PN5,PN6)
      CALL CROSSLP(X,Y,Z,DBX3,DBY3,DBZ3,PN7,PN8,PN9)
!
!    NOW AN EQUATORIAL LOOP ON THE NIGHTSIDE
!
      CALL CIRCLE(X-PN10,Y,Z,PN11,DBX4,DBY4,DBZ4)
!
!   NOW A 4-LOOP SYSTEM ON THE NIGHTSIDE
!

      CALL LOOPS4(X,Y,Z,DBX5,DBY5,DBZ5,PN12,PN13,PN14,PN15,PN16,PN17)

!---------------------------------------------------------------------

!                           NOW COMPUTE THE FIELD COMPONENTS:

      BX=PL1*DBX1+PL2*DBX2+PL3*DBX3+PL4*DBX4+PL5*DBX5
      BY=PL1*DBY1+PL2*DBY2+PL3*DBY3+PL4*DBY4+PL5*DBY5
      BZ=PL1*DBZ1+PL2*DBZ2+PL3*DBZ3+PL4*DBZ4+PL5*DBZ5

       RETURN
       END
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
       SUBROUTINE LOOPS4(X,Y,Z,BX,BY,BZ,XC,YC,ZC,R,THETA,PHI)
!
!   RETURNS FIELD COMPONENTS FROM A SYSTEM OF 4 CURRENT LOOPS, POSITIONED
!     SYMMETRICALLY WITH RESPECT TO NOON-MIDNIGHT MERIDIAN AND EQUATORIAL
!      PLANES.
!  INPUT: X,Y,Z OF A POINT OF SPACE
!        XC,YC,ZC (YC > 0 AND ZC > 0) - POSITION OF THE CENTER OF THE
!                                         1ST-QUADRANT LOOP
!        R - LOOP RADIUS (THE SAME FOR ALL FOUR)
!        THETA, PHI  -  SPECIFY THE ORIENTATION OF THE NORMAL OF THE 1ST LOOP
!      -----------------------------------------------------------

        IMPLICIT REAL*8 (A-H,O-Z)
      save
!
          CT=DCOS(THETA)
          ST=DSIN(THETA)
          CP=DCOS(PHI)
          SP=DSIN(PHI)
!------------------------------------1ST QUADRANT:
        XS=(X-XC)*CP+(Y-YC)*SP
        YSS=(Y-YC)*CP-(X-XC)*SP
        ZS=Z-ZC
        XSS=XS*CT-ZS*ST
        ZSS=ZS*CT+XS*ST

        CALL CIRCLE(XSS,YSS,ZSS,R,BXSS,BYS,BZSS)
          BXS=BXSS*CT+BZSS*ST
          BZ1=BZSS*CT-BXSS*ST
          BX1=BXS*CP-BYS*SP
          BY1=BXS*SP+BYS*CP
!-------------------------------------2nd QUADRANT:
        XS=(X-XC)*CP-(Y+YC)*SP
        YSS=(Y+YC)*CP+(X-XC)*SP
        ZS=Z-ZC
        XSS=XS*CT-ZS*ST
        ZSS=ZS*CT+XS*ST

        CALL CIRCLE(XSS,YSS,ZSS,R,BXSS,BYS,BZSS)
          BXS=BXSS*CT+BZSS*ST
          BZ2=BZSS*CT-BXSS*ST
          BX2=BXS*CP+BYS*SP
          BY2=-BXS*SP+BYS*CP
!-------------------------------------3RD QUADRANT:
        XS=-(X-XC)*CP+(Y+YC)*SP
        YSS=-(Y+YC)*CP-(X-XC)*SP
        ZS=Z+ZC
        XSS=XS*CT-ZS*ST
        ZSS=ZS*CT+XS*ST

        CALL CIRCLE(XSS,YSS,ZSS,R,BXSS,BYS,BZSS)
          BXS=BXSS*CT+BZSS*ST
          BZ3=BZSS*CT-BXSS*ST
          BX3=-BXS*CP-BYS*SP
          BY3=BXS*SP-BYS*CP
!-------------------------------------4TH QUADRANT:
        XS=-(X-XC)*CP-(Y-YC)*SP
        YSS=-(Y-YC)*CP+(X-XC)*SP
        ZS=Z+ZC
        XSS=XS*CT-ZS*ST
        ZSS=ZS*CT+XS*ST

        CALL CIRCLE(XSS,YSS,ZSS,R,BXSS,BYS,BZSS)
          BXS=BXSS*CT+BZSS*ST
          BZ4=BZSS*CT-BXSS*ST
          BX4=-BXS*CP+BYS*SP
          BY4=-BXS*SP-BYS*CP

        BX=BX1+BX2+BX3+BX4
        BY=BY1+BY2+BY3+BY4
        BZ=BZ1+BZ2+BZ3+BZ4

         RETURN
         END
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
      SUBROUTINE R2SHEET(X,Y,Z,BX,BY,BZ)
!
      IMPLICIT REAL*8 (A-H,O-Z)
      save
!
      DATA PNONX1,PNONX2,PNONX3,PNONX4,PNONX5,PNONX6,PNONX7,PNONX8, &
           PNONY1,PNONY2,PNONY3,PNONY4,PNONY5,PNONY6,PNONY7,PNONY8, &
           PNONZ1,PNONZ2,PNONZ3,PNONZ4,PNONZ5,PNONZ6,PNONZ7,PNONZ8 &
      /-19.0969D0,-9.28828D0,-0.129687D0,5.58594D0,22.5055D0, &
        0.483750D-01,0.396953D-01,0.579023D-01,-13.6750D0,-6.70625D0, &
        2.31875D0,11.4062D0,20.4562D0,0.478750D-01,0.363750D-01, &
       0.567500D-01,-16.7125D0,-16.4625D0,-0.1625D0,5.1D0,23.7125D0, &
       0.355625D-01,0.318750D-01,0.538750D-01/
!
!
      DATA A1,A2,A3,A4,A5,A6,A7,A8,A9,A10,A11,A12,A13,A14,A15,A16,A17, &
        A18,A19,A20,A21,A22,A23,A24,A25,A26,A27,A28,A29,A30,A31,A32,A33, &
        A34,A35,A36,A37,A38,A39,A40,A41,A42,A43,A44,A45,A46,A47,A48,A49, &
        A50,A51,A52,A53,A54,A55,A56,A57,A58,A59,A60,A61,A62,A63,A64,A65, &
        A66,A67,A68,A69,A70,A71,A72,A73,A74,A75,A76,A77,A78,A79,A80 &
       /8.07190D0,-7.39582D0,-7.62341D0,0.684671D0,-13.5672D0,11.6681D0, &
       13.1154d0,-0.890217D0,7.78726D0,-5.38346D0,-8.08738D0,0.609385D0, &
       -2.70410D0, 3.53741D0,3.15549D0,-1.11069D0,-8.47555D0,0.278122D0, &
        2.73514D0,4.55625D0,13.1134D0,1.15848D0,-3.52648D0,-8.24698D0, &
       -6.85710D0,-2.81369D0, 2.03795D0, 4.64383D0,2.49309D0,-1.22041D0, &
       -1.67432D0,-0.422526D0,-5.39796D0,7.10326D0,5.53730D0,-13.1918D0, &
        4.67853D0,-7.60329D0,-2.53066D0, 7.76338D0, 5.60165D0,5.34816D0, &
       -4.56441D0,7.05976D0,-2.62723D0,-0.529078D0,1.42019D0,-2.93919D0, &
        55.6338D0,-1.55181D0,39.8311D0,-80.6561D0,-46.9655D0,32.8925D0, &
       -6.32296D0,19.7841D0,124.731D0,10.4347D0,-30.7581D0,102.680D0, &
       -47.4037D0,-3.31278D0,9.37141D0,-50.0268D0,-533.319D0,110.426D0, &
        1000.20D0,-1051.40D0, 1619.48D0,589.855D0,-1462.73D0,1087.10D0, &
        -1994.73D0,-1654.12D0,1263.33D0,-260.210D0,1424.84D0,1255.71D0, &
        -956.733D0, 219.946D0/
!
!
      DATA B1,B2,B3,B4,B5,B6,B7,B8,B9,B10,B11,B12,B13,B14,B15,B16,B17, &
        B18,B19,B20,B21,B22,B23,B24,B25,B26,B27,B28,B29,B30,B31,B32,B33, &
        B34,B35,B36,B37,B38,B39,B40,B41,B42,B43,B44,B45,B46,B47,B48,B49, &
        B50,B51,B52,B53,B54,B55,B56,B57,B58,B59,B60,B61,B62,B63,B64,B65, &
        B66,B67,B68,B69,B70,B71,B72,B73,B74,B75,B76,B77,B78,B79,B80 &
      /-9.08427D0,10.6777D0,10.3288D0,-0.969987D0,6.45257D0,-8.42508D0, &
       -7.97464D0,1.41996D0,-1.92490D0,3.93575D0,2.83283D0,-1.48621D0, &
      0.244033D0,-0.757941D0,-0.386557D0,0.344566D0,9.56674D0,-2.5365D0, &
       -3.32916D0,-5.86712D0,-6.19625D0,1.83879D0,2.52772D0,4.34417D0, &
       1.87268D0,-2.13213D0,-1.69134D0,-.176379D0,-.261359D0,.566419D0, &
       0.3138D0,-0.134699D0,-3.83086D0,-8.4154D0,4.77005D0,-9.31479D0, &
       37.5715D0,19.3992D0,-17.9582D0,36.4604D0,-14.9993D0,-3.1442D0, &
       6.17409D0,-15.5519D0,2.28621D0,-0.891549D-2,-.462912D0,2.47314D0, &
       41.7555D0,208.614D0,-45.7861D0,-77.8687D0,239.357D0,-67.9226D0, &
       66.8743D0,238.534D0,-112.136D0,16.2069D0,-40.4706D0,-134.328D0, &
       21.56D0,-0.201725D0,2.21D0,32.5855D0,-108.217D0,-1005.98D0, &
       585.753D0,323.668D0,-817.056D0,235.750D0,-560.965D0,-576.892D0, &
       684.193D0,85.0275D0,168.394D0,477.776D0,-289.253D0,-123.216D0, &
       75.6501D0,-178.605D0/
!
      DATA C1,C2,C3,C4,C5,C6,C7,C8,C9,C10,C11,C12,C13,C14,C15,C16,C17, &
        C18,C19,C20,C21,C22,C23,C24,C25,C26,C27,C28,C29,C30,C31,C32,C33, &
        C34,C35,C36,C37,C38,C39,C40,C41,C42,C43,C44,C45,C46,C47,C48,C49, &
        C50,C51,C52,C53,C54,C55,C56,C57,C58,C59,C60,C61,C62,C63,C64,C65, &
        C66,C67,C68,C69,C70,C71,C72,C73,C74,C75,C76,C77,C78,C79,C80 &
       / 1167.61D0,-917.782D0,-1253.2D0,-274.128D0,-1538.75D0,1257.62D0, &
       1745.07D0,113.479D0,393.326D0,-426.858D0,-641.1D0,190.833D0, &
       -29.9435D0,-1.04881D0,117.125D0,-25.7663D0,-1168.16D0,910.247D0, &
       1239.31D0,289.515D0,1540.56D0,-1248.29D0,-1727.61D0,-131.785D0, &
       -394.577D0,426.163D0,637.422D0,-187.965D0,30.0348D0,0.221898D0, &
       -116.68D0,26.0291D0,12.6804D0,4.84091D0,1.18166D0,-2.75946D0, &
       -17.9822D0,-6.80357D0,-1.47134D0,3.02266D0,4.79648D0,0.665255D0, &
       -0.256229D0,-0.857282D-1,-0.588997D0,0.634812D-1,0.164303D0, &
       -0.15285D0,22.2524D0,-22.4376D0,-3.85595D0,6.07625D0,-105.959D0, &
       -41.6698D0,0.378615D0,1.55958D0,44.3981D0,18.8521D0,3.19466D0, &
        5.89142D0,-8.63227D0,-2.36418D0,-1.027D0,-2.31515D0,1035.38D0, &
        2040.66D0,-131.881D0,-744.533D0,-3274.93D0,-4845.61D0,482.438D0, &
       1567.43D0,1354.02D0,2040.47D0,-151.653D0,-845.012D0,-111.723D0, &
       -265.343D0,-26.1171D0,216.632D0/
!
!------------------------------------------------------------------
!
       XKS=XKSI(X,Y,Z)    !  variation across the current sheet
       T1X=XKS/DSQRT(XKS**2+PNONX6**2)
       T2X=PNONX7**3/DSQRT(XKS**2+PNONX7**2)**3
       T3X=XKS/DSQRT(XKS**2+PNONX8**2)**5 *3.493856D0*PNONX8**4
!
       T1Y=XKS/DSQRT(XKS**2+PNONY6**2)
       T2Y=PNONY7**3/DSQRT(XKS**2+PNONY7**2)**3
       T3Y=XKS/DSQRT(XKS**2+PNONY8**2)**5 *3.493856D0*PNONY8**4
!
       T1Z=XKS/DSQRT(XKS**2+PNONZ6**2)
       T2Z=PNONZ7**3/DSQRT(XKS**2+PNONZ7**2)**3
       T3Z=XKS/DSQRT(XKS**2+PNONZ8**2)**5 *3.493856D0*PNONZ8**4
!
      RHO2=X*X+Y*Y
      R=DSQRT(RHO2+Z*Z)
      RHO=DSQRT(RHO2)
!
      C1P=X/RHO
      S1P=Y/RHO
      S2P=2.D0*S1P*C1P
      C2P=C1P*C1P-S1P*S1P
      S3P=S2P*C1P+C2P*S1P
      C3P=C2P*C1P-S2P*S1P
      S4P=S3P*C1P+C3P*S1P
      CT=Z/R
! jah, foresys : Result of assignment to ST is not used
! jah,      ST=RHO/R
!
      S1=FEXP(CT,PNONX1)
      S2=FEXP(CT,PNONX2)
      S3=FEXP(CT,PNONX3)
      S4=FEXP(CT,PNONX4)
      S5=FEXP(CT,PNONX5)
!
!                   NOW COMPUTE THE GSM FIELD COMPONENTS:
!
!
      BX=S1*((A1+A2*T1X+A3*T2X+A4*T3X) &
              +C1P*(A5+A6*T1X+A7*T2X+A8*T3X) &
              +C2P*(A9+A10*T1X+A11*T2X+A12*T3X) &
              +C3P*(A13+A14*T1X+A15*T2X+A16*T3X)) &
          +S2*((A17+A18*T1X+A19*T2X+A20*T3X) &
              +C1P*(A21+A22*T1X+A23*T2X+A24*T3X) &
              +C2P*(A25+A26*T1X+A27*T2X+A28*T3X) &
              +C3P*(A29+A30*T1X+A31*T2X+A32*T3X)) &
          +S3*((A33+A34*T1X+A35*T2X+A36*T3X) &
              +C1P*(A37+A38*T1X+A39*T2X+A40*T3X) &
              +C2P*(A41+A42*T1X+A43*T2X+A44*T3X) &
              +C3P*(A45+A46*T1X+A47*T2X+A48*T3X)) &
          +S4*((A49+A50*T1X+A51*T2X+A52*T3X) &
              +C1P*(A53+A54*T1X+A55*T2X+A56*T3X) &
              +C2P*(A57+A58*T1X+A59*T2X+A60*T3X) &
              +C3P*(A61+A62*T1X+A63*T2X+A64*T3X)) &
          +S5*((A65+A66*T1X+A67*T2X+A68*T3X) &
              +C1P*(A69+A70*T1X+A71*T2X+A72*T3X) &
              +C2P*(A73+A74*T1X+A75*T2X+A76*T3X) &
              +C3P*(A77+A78*T1X+A79*T2X+A80*T3X))
!
!
      S1=FEXP(CT,PNONY1)
      S2=FEXP(CT,PNONY2)
      S3=FEXP(CT,PNONY3)
      S4=FEXP(CT,PNONY4)
      S5=FEXP(CT,PNONY5)
!
      BY=S1*(S1P*(B1+B2*T1Y+B3*T2Y+B4*T3Y) &
            +S2P*(B5+B6*T1Y+B7*T2Y+B8*T3Y) &
            +S3P*(B9+B10*T1Y+B11*T2Y+B12*T3Y) &
            +S4P*(B13+B14*T1Y+B15*T2Y+B16*T3Y)) &
        +S2*(S1P*(B17+B18*T1Y+B19*T2Y+B20*T3Y) &
            +S2P*(B21+B22*T1Y+B23*T2Y+B24*T3Y) &
            +S3P*(B25+B26*T1Y+B27*T2Y+B28*T3Y) &
            +S4P*(B29+B30*T1Y+B31*T2Y+B32*T3Y)) &
        +S3*(S1P*(B33+B34*T1Y+B35*T2Y+B36*T3Y) &
            +S2P*(B37+B38*T1Y+B39*T2Y+B40*T3Y) &
            +S3P*(B41+B42*T1Y+B43*T2Y+B44*T3Y) &
            +S4P*(B45+B46*T1Y+B47*T2Y+B48*T3Y)) &
        +S4*(S1P*(B49+B50*T1Y+B51*T2Y+B52*T3Y) &
            +S2P*(B53+B54*T1Y+B55*T2Y+B56*T3Y) &
            +S3P*(B57+B58*T1Y+B59*T2Y+B60*T3Y) &
            +S4P*(B61+B62*T1Y+B63*T2Y+B64*T3Y)) &
        +S5*(S1P*(B65+B66*T1Y+B67*T2Y+B68*T3Y) &
            +S2P*(B69+B70*T1Y+B71*T2Y+B72*T3Y) &
            +S3P*(B73+B74*T1Y+B75*T2Y+B76*T3Y) &
            +S4P*(B77+B78*T1Y+B79*T2Y+B80*T3Y))
!
      S1=FEXP1(CT,PNONZ1)
      S2=FEXP1(CT,PNONZ2)
      S3=FEXP1(CT,PNONZ3)
      S4=FEXP1(CT,PNONZ4)
      S5=FEXP1(CT,PNONZ5)
!
      BZ=S1*((C1+C2*T1Z+C3*T2Z+C4*T3Z) &
            +C1P*(C5+C6*T1Z+C7*T2Z+C8*T3Z) &
            +C2P*(C9+C10*T1Z+C11*T2Z+C12*T3Z) &
            +C3P*(C13+C14*T1Z+C15*T2Z+C16*T3Z)) &
         +S2*((C17+C18*T1Z+C19*T2Z+C20*T3Z) &
            +C1P*(C21+C22*T1Z+C23*T2Z+C24*T3Z) &
            +C2P*(C25+C26*T1Z+C27*T2Z+C28*T3Z) &
            +C3P*(C29+C30*T1Z+C31*T2Z+C32*T3Z)) &
         +S3*((C33+C34*T1Z+C35*T2Z+C36*T3Z) &
            +C1P*(C37+C38*T1Z+C39*T2Z+C40*T3Z) &
            +C2P*(C41+C42*T1Z+C43*T2Z+C44*T3Z) &
            +C3P*(C45+C46*T1Z+C47*T2Z+C48*T3Z)) &
         +S4*((C49+C50*T1Z+C51*T2Z+C52*T3Z) &
            +C1P*(C53+C54*T1Z+C55*T2Z+C56*T3Z) &
            +C2P*(C57+C58*T1Z+C59*T2Z+C60*T3Z) &
            +C3P*(C61+C62*T1Z+C63*T2Z+C64*T3Z)) &
         +S5*((C65+C66*T1Z+C67*T2Z+C68*T3Z) &
            +C1P*(C69+C70*T1Z+C71*T2Z+C72*T3Z) &
            +C2P*(C73+C74*T1Z+C75*T2Z+C76*T3Z) &
            +C3P*(C77+C78*T1Z+C79*T2Z+C80*T3Z))
!
       RETURN
       END
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

      DOUBLE PRECISION FUNCTION XKSI(X,Y,Z)
!
      IMPLICIT REAL*8 (A-H,O-Z)
      save
!
!   A11 - C72, R0, and DR below  ARE STRETCH PARAMETERS (P.26-27, NB# 3),
!
      DATA A11A12,A21A22,A41A42,A51A52,A61A62,B11B12,B21B22,C61C62, &
        C71C72,R0,DR &
       /0.305662d0,-0.383593d0,0.2677733d0,-0.097656d0,-0.636034d0, &
        -0.359862d0,0.424706d0,-0.126366d0,0.292578d0,1.21563d0,7.50937d0/

      DATA TNOON,DTETA/0.3665191d0,0.09599309d0/ ! Correspond to noon and midnight
!                                         latitudes 69 and 63.5 degs, resp.
       DR2=DR*DR
!
       X2=X*X
       Y2=Y*Y
       Z2=Z*Z
! jah, foresys : Result of assignment to XY is not used
! jah,       XY=X*Y
! jah, foresys : Result of assignment to XYZ is not used
! jah,       XYZ=XY*Z
       R2=X2+Y2+Z2
       R=DSQRT(R2)
! jah, foresys : Result of assignment to R3 is not used
! jah,       R3=R2*R
! jah, foresys : Result of assignment to R4 is not used
! jah,       R4=R2*R2
       XR=X/R
       YR=Y/R
       ZR=Z/R
!
       IF (R.LT.R0) THEN
         PR=0.D0
       ELSE
         PR=DSQRT((R-R0)**2+DR2)-DR
       ENDIF
!
      F=X+PR*(A11A12+A21A22*XR+A41A42*XR*XR+A51A52*YR*YR+ &
              A61A62*ZR*ZR)
      G=Y+PR*(B11B12*YR+B21B22*XR*YR)
      H=Z+PR*(C61C62*ZR+C71C72*XR*ZR)
      G2=G*G
!
      FGH=F**2+G2+H**2
      FGH32=DSQRT(FGH)**3
      FCHSG2=F**2+G2

      IF (FCHSG2.LT.1.D-5) THEN
         XKSI=-1.D0               !  THIS IS JUST FOR ELIMINATING PROBLEMS
         RETURN                    !  ON THE Z-AXIS
      ENDIF

      SQFCHSG2=DSQRT(FCHSG2)
      ALPHA=FCHSG2/FGH32
      THETA=TNOON+0.5D0*DTETA*(1.D0-F/SQFCHSG2)
      PHI=DSIN(THETA)**2
!
      XKSI=ALPHA-PHI
!
      RETURN
      END
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
        FUNCTION FEXP(S,A)
         IMPLICIT REAL*8 (A-H,O-Z)
      save
          DATA E/2.718281828459D0/
          IF (A.LT.0.D0) FEXP=DSQRT(-2.D0*A*E)*S*DEXP(A*S*S)
          IF (A.GE.0.D0) FEXP=S*DEXP(A*(S*S-1.D0))
         RETURN
         END
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
        FUNCTION FEXP1(S,A)
         IMPLICIT REAL*8 (A-H,O-Z)
      save
         IF (A.LE.0.D0) FEXP1=DEXP(A*S*S)
         IF (A.GT.0.D0) FEXP1=DEXP(A*(S*S-1.D0))
         RETURN
         END
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
         DOUBLE PRECISION FUNCTION TKSI(XKSI,XKS0,DXKSI)
         IMPLICIT REAL*8 (A-H,O-Z)
      save
!!!         SAVE M,TDZ3
         DATA M/0/
!
         IF (M.EQ.0) THEN
         TDZ3=2.d0*DXKSI**3
         M=1
         ENDIF
!
         IF (XKSI-XKS0.LT.-DXKSI) TKSII=0.d0
         IF (XKSI-XKS0.GE.DXKSI)  TKSII=1.d0
!
         IF (XKSI.GE.XKS0-DXKSI.AND.XKSI.LT.XKS0) THEN
           BR3=(XKSI-XKS0+DXKSI)**3
           TKSII=1.5d0*BR3/(TDZ3+BR3)
         ENDIF
!
         IF (XKSI.GE.XKS0.AND.XKSI.LT.XKS0+DXKSI) THEN
           BR3=(XKSI-XKS0-DXKSI)**3
           TKSII=1.d0+1.5d0*BR3/(TDZ3-BR3)
         ENDIF
           TKSI=TKSII
         END
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
       SUBROUTINE DIPOLE_T96(PS,X,Y,Z,BX,BY,BZ)
!
!  CALCULATES GSM COMPONENTS OF GEODIPOLE FIELD WITH THE DIPOLE MOMENT
!  CORRESPONDING TO THE EPOCH OF 1980.
!------------INPUT PARAMETERS:
!   PS - GEODIPOLE TILT ANGLE IN RADIANS, X,Y,Z - GSM COORDINATES IN RE
!------------OUTPUT PARAMETERS:
!   BX,BY,BZ - FIELD COMPONENTS IN GSM SYSTEM, IN NANOTESLA.
!
!
!                   AUTHOR: NIKOLAI A. TSYGANENKO
!                           INSTITUTE OF PHYSICS
!                           ST.-PETERSBURG STATE UNIVERSITY
!                           STARY PETERGOF 198904
!                           ST.-PETERSBURG
!                           RUSSIA
!
      IMPLICIT NONE
!
      REAL PS,X,Y,Z,BX,BY,BZ,PSI,SPS,CPS,P,U,V,T,Q
      INTEGER M
      save

      DATA M,PSI/0,5./
      IF(M.EQ.1.AND.ABS(PS-PSI).LT.1.E-5) GOTO 1
      SPS=SIN(PS)
      CPS=COS(PS)
      PSI=PS
      M=1
  1   P=X**2
      U=Z**2
      V=3.*Z*X
      T=Y**2
      Q=30574./SQRT(P+T+U)**5
      BX=Q*((T+U-2.*P)*SPS-V*CPS)
      BY=-3.*Y*Q*(X*SPS+Z*CPS)
      BZ=Q*((P+T-2.*U)*CPS-V*SPS)
      RETURN
      END

!
!     Fin du modele T96_01
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

!     Debut du modele T01_01, fichier T01_01.txt, telecharger le 17/11/05
!
      SUBROUTINE T01_01 (IOPT,PARMOD,PS,X,Y,Z,BX,BY,BZ)
!
!     RELEASE DATE OF THIS VERSION:   AUGUST 8, 2001.
!
!--------------------------------------------------------------------
!   A DATA-BASED MODEL OF THE EXTERNAL (I.E., WITHOUT EARTH'S CONTRIBUTION) PART OF THE
!   MAGNETOSPHERIC MAGNETIC FIELD, CALIBRATED BY
!    (1) SOLAR WIND PRESSURE PDYN (NANOPASCALS),
!    (2) DST (NANOTESLA),
!    (3) BYIMF,
!    (4) BZIMF (NANOTESLA)
!    (5) G1-INDEX
!    (6) G2-INDEX  (SEE TSYGANENKO [2001] FOR AN EXACT DEFINITION OF THESE TWO INDICES)

!   THESE INPUT PARAMETERS SHOULD BE PLACED IN THE FIRST 6 ELEMENTS
!   OF THE ARRAY PARMOD(10).
!
!   THE REST OF THE INPUT VARIABLES ARE: THE GEODIPOLE TILT ANGLE PS (RADIANS),
!     AND   X,Y,Z -  GSM POSITION (RE)
!
!   IOPT  IS JUST A DUMMY INPUT PARAMETER, NECESSARY TO MAKE THIS SUBROUTINE
!   COMPATIBLE WITH THE TRACING SOFTWARE PACKAGE (GEOPACK). IN THIS MODEL
!   IT DOES NOT AFFECT THE OUTPUT FIELD.
!
!*******************************************************************************************
!** ATTENTION:  THE MODEL IS BASED ON DATA TAKEN SUNWARD FROM X=-15Re, AND HENCE BECOMES   *
!**              INVALID AT LARGER TAILWARD DISTANCES !!!                                  *
!*******************************************************************************************
!
!   OUTPUT:  GSM COMPONENTS OF THE EXTERNAL MAGNETIC FIELD (BX,BY,BZ, nanotesla)
!            COMPUTED AS A SUM OF CONTRIBUTIONS FROM PRINCIPAL FIELD SOURCES
!
!  (C) Copr. 2001, Nikolai A. Tsyganenko, USRA, Code 690.2, NASA GSFC
!      Greenbelt, MD 20771, USA
!
!                            REFERENCE:
!
!    N. A. Tsyganenko, A new data-based model of the near magnetosphere magnetic field:
!       1. Mathematical structure.
!       2. Parameterization and fitting to observations.
!
!             (submitted to JGR, July 2001; available online in the PDF format
!              from anonymous ftp-area www-istp.gsfc.nasa.gov,  /pub/kolya/T01)
!
!----------------------------------------------------------------------
!
      REAL PARMOD(10),PS,X,Y,Z,BX,BY,BZ
      REAL*8 A(43),PDYN,DST_AST,BYIMF,BZIMF,G1,G2,PSS,XX,YY,ZZ, &
        BXCF,BYCF,BZCF,BXT1,BYT1,BZT1,BXT2,BYT2,BZT2, &
        BXSRC,BYSRC,BZSRC,BXPRC,BYPRC,BZPRC, BXR11,BYR11,BZR11, &
        BXR12,BYR12,BZR12,BXR21,BYR21,BZR21,BXR22,BYR22,BZR22,HXIMF, &
        HYIMF,HZIMF,BBX,BBY,BBZ
      save
!
      DATA A /1.00000d0,2.48341d0,.58315d0,.31917d0,-.08796d0,-1.17266d0,3.57478d0, &
       -.06143d0,-.01113d0,.70924d0,-.01675d0,-.46056d0,-.87754d0,-.03025d0,.18933d0, &
       .28089d0,.16636d0,-.02932d0,.02592d0,-.23537d0,-.07659d0,.09117d0,-.02492d0, &
       .06816d0,.55417d0,.68918d0,-.04604d0,2.33521d0,3.90147d0,1.28978d0,.03139d0, &
       .98751d0,.21824d0,41.60182d0,1.12761d0,.01376d0,1.02751d0,.02969d0,.15790d0, &
       8.94335d0,28.31280d0,1.24364d0,.38013d0/

!inut.
  iopt=0
!
      IF (X.LT.-20.) THEN
      PRINT *, &
       '  ATTENTION:  THE MODEL IS VALID SUNWARD FROM X=-15 Re ONLY,'
      PRINT *,'              WHILE YOU ARE TRYING TO USE IT AT X=', X
! jah, PAUSE
      stop 'T01  *** ABORTED ! MODEL IS VALID SUNWARD FROM X=-15 Re ***'
      ENDIF
!
      PDYN=dble(PARMOD(1))
      DST_AST=dble(PARMOD(2)*0.8-13.*SQRT(sngl(PDYN)))
      BYIMF=dble(PARMOD(3))
      BZIMF=dble(PARMOD(4))

      G1=dble(PARMOD(5))
      G2=dble(PARMOD(6))
      PSS=dble(PS)
      XX=dble(X)
      YY=dble(Y)
      d0ZZ=Z
!
      CALL EXTALL (0,0,0,0,A,43,PDYN,DST_AST,BYIMF,BZIMF,G1,G2, &
        PSS,XX,YY,ZZ,BXCF,BYCF,BZCF,BXT1,BYT1,BZT1,BXT2,BYT2,BZT2, &
        BXSRC,BYSRC,BZSRC,BXPRC,BYPRC,BZPRC, BXR11,BYR11,BZR11, &
        BXR12,BYR12,BZR12,BXR21,BYR21,BZR21,BXR22,BYR22,BZR22,HXIMF, &
        HYIMF,HZIMF,BBX,BBY,BBZ)
!
! jah, foresys : Precision loss in assignment from real*8 to real
! jah,      BX=BBX
      BX=sngl(BBX)
! jah, foresys : Precision loss in assignment from real*8 to real
! jah,       BY=BBY
      BY=sngl(BBY)
! jah, foresys : Precision loss in assignment from real*8 to real
! jah,      BZ=BBZ
      BZ=sngl(BBZ)
!
      RETURN
      END
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

      SUBROUTINE EXTALL (IOPGEN,IOPT,IOPB,IOPR,A,NTOT, &
        PDYN,DST,BYIMF,BZIMF,VBIMF1,VBIMF2,PS,X,Y,Z, &
        BXCF,BYCF,BZCF,BXT1,BYT1,BZT1,BXT2,BYT2,BZT2, &
        BXSRC,BYSRC,BZSRC,BXPRC,BYPRC,BZPRC, BXR11,BYR11,BZR11, &
        BXR12,BYR12,BZR12,BXR21,BYR21,BZR21,BXR22,BYR22,BZR22,HXIMF, &
        HYIMF,HZIMF,BX,BY,BZ)
!
!   IOPGEN - GENERAL OPTION FLAG:  IOPGEN=0 - CALCULATE TOTAL FIELD
!                                  IOPGEN=1 - DIPOLE SHIELDING ONLY
!                                  IOPGEN=2 - TAIL FIELD ONLY
!                                  IOPGEN=3 - BIRKELAND FIELD ONLY
!                                  IOPGEN=4 - RING CURRENT FIELD ONLY
!                                  IOPGEN=5 - INTERCONNECTION FIELD ONLY
!
!   IOPT -  TAIL FIELD FLAG:       IOPT=0  -  BOTH MODES
!                                  IOPT=1  -  MODE 1 ONLY
!                                  IOPT=2  -  MODE 2 ONLY
!
!   IOPB -  BIRKELAND FIELD FLAG:  IOPB=0  -  ALL 4 TERMS
!                                  IOPB=1  -  REGION 1, MODES 1 AND 2
!                                  IOPB=2  -  REGION 2, MODES 1 AND 2
!
!   IOPR -  RING CURRENT FLAG:     IOPR=0  -  BOTH SRC AND PRC
!                                  IOPR=1  -  SRC ONLY
!                                  IOPR=2  -  PRC ONLY
!
      IMPLICIT  REAL * 8  (A - H, O - Z)
!
      DIMENSION A(NTOT)
      save
!
      COMMON /TAIL/ DXSHIFT1,DXSHIFT2,D,DELTADY  ! THE COMMON BLOCKS FORWARD NONLINEAR PARAMETERS
      COMMON /BIRKPAR/ XKAPPA1,XKAPPA2
      COMMON /RCPAR/ SC_SY,SC_AS,PHI
      COMMON /G/ G
      COMMON /RH0/ RH0
!
      DATA A0_A,A0_S0,A0_X0 /34.586D0,1.1960D0,3.4397D0/   !   SHUE ET AL. PARAMETERS
      DATA DSIG /0.003D0/, RH0,RH2 /8.0D0,-5.2D0/
!
      XAPPA=(PDYN/2.d0)**A(39)   !  NOW THIS IS A VARIABLE PARAMETER
      RH0=A(40)
      G=A(41)

      XAPPA3=XAPPA**3

      XX=X*XAPPA
      YY=Y*XAPPA
      ZZ=Z*XAPPA
!
      SPS=DSIN(PS)
!
      X0=A0_X0/XAPPA
      AM=A0_A/XAPPA
      S0=A0_S0
!
! jah, foresys : Result of assignment to BPERP is not used
! jah,      BPERP=DSQRT(BYIMF**2+BZIMF**2)
!
!   CALCULATE THE IMF CLOCK ANGLE:
!
        IF (BYIMF.EQ.0.D0.AND.BZIMF.EQ.0.D0) THEN
            THETA=0.D0
         ELSE
            THETA=DATAN2(BYIMF,BZIMF)
            IF (THETA.LE.0.D0) THETA=THETA+6.283185307D0
        ENDIF
!
! jah, foresys : Result of assignment to CT is not used
! jah,       CT=COS(THETA)
! jah, foresys : Result of assignment to ST is not used
! jah,       ST=SIN(THETA)
! jah, foresys : Result of assignment to YS is not used
! jah,       YS=Y*CT-Z*ST
! jah, foresys : Result of assignment to ZS is not used
! jah,       ZS=Z*CT+Y*ST

       STHETAH=SIN(THETA/2.d0)**2
!
!  CALCULATE "IMF" COMPONENTS OUTSIDE THE MAGNETOPAUSE LAYER (HENCE BEGIN WITH "O")
!  THEY ARE NEEDED ONLY IF THE POINT (X,Y,Z) IS WITHIN THE TRANSITION MAGNETOPAUSE LAYER
!  OR OUTSIDE THE MAGNETOSPHERE:
!
      FACTIMF=A(24)+A(25)*STHETAH
!
      OIMFX=0.D0
      OIMFY=BYIMF*FACTIMF
      OIMFZ=BZIMF*FACTIMF
!
      R=SQRT(X**2+Y**2+Z**2)
      XSS=X
      ZSS=Z

  1   XSOLD=XSS      !   BEGIN ITERATIVE SEARCH OF UNWARPED COORDS (TO FIND SIGMA)
      ZSOLD=ZSS

      RH=RH0+RH2*(ZSS/R)**2
      SINPSAS=SPS/(1.D0+(R/RH)**3)**0.33333333D0
      COSPSAS=DSQRT(1.D0-SINPSAS**2)
      ZSS=X*SINPSAS+Z*COSPSAS
      XSS=X*COSPSAS-Z*SINPSAS
      DD=DABS(XSS-XSOLD)+DABS(ZSS-ZSOLD)
      IF (DD.GT.1.D-6) GOTO 1
!                                END OF ITERATIVE SEARCH
      RHO2=Y**2+ZSS**2
      ASQ=AM**2
      XMXM=AM+XSS-X0
      IF (XMXM.LT.0.d0) XMXM=0.d0 ! THE BOUNDARY IS A CYLINDER TAILWARD OF X=X0-AM
      AXX0=XMXM**2
      ARO=ASQ+RHO2
      SIGMA=DSQRT((ARO+AXX0+SQRT((ARO+AXX0)**2-4.d0*ASQ*AXX0))/(2.d0*ASQ))
!
!   NOW, THERE ARE THREE POSSIBLE CASES:
!    (1) INSIDE THE MAGNETOSPHERE   (SIGMA
!    (2) IN THE BOUNDARY LAYER
!    (3) OUTSIDE THE MAGNETOSPHERE AND B.LAYER
!       FIRST OF ALL, CONSIDER THE CASES (1) AND (2):
!
!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      IF (SIGMA.LT.S0+DSIG) THEN  !  CASES (1) OR (2); CALCULATE THE MODEL FIELD
!                              (WITH THE POTENTIAL "PENETRATED" INTERCONNECTION FIELD):
!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!
      IF (IOPGEN.LE.1) THEN
         CALL SHLCAR3X3(XX,YY,ZZ,PS,CFX,CFY,CFZ)         !  DIPOLE SHIELDING FIELD
         BXCF=CFX*XAPPA3
         BYCF=CFY*XAPPA3
         BZCF=CFZ*XAPPA3
      ELSE
         BXCF=0.D0
         BYCF=0.D0
         BZCF=0.D0
      ENDIF

      IF (IOPGEN.EQ.0.OR.IOPGEN.EQ.2) THEN
         DXSHIFT1=A(26)+A(27)*VBIMF2
         DXSHIFT2=0.D0
         D=A(28)
         DELTADY=A(29)
         CALL DEFORMED (IOPT,PS,XX,YY,ZZ,                 &!  TAIL FIELD (THREE MODES)
          BXT1,BYT1,BZT1,BXT2,BYT2,BZT2)
      ELSE
         BXT1=0.D0
         BYT1=0.D0
         BZT1=0.D0
         BXT2=0.D0
         BYT2=0.D0
         BZT2=0.D0
      ENDIF

      IF (IOPGEN.EQ.0.OR.IOPGEN.EQ.3) THEN
         XKAPPA1=A(35)+A(36)*VBIMF2
         XKAPPA2=A(37)+A(38)*VBIMF2
         CALL BIRK_TOT (IOPB,PS,XX,YY,ZZ,BXR11,BYR11,BZR11,BXR12,BYR12, &
         BZR12,BXR21,BYR21,BZR21,BXR22,BYR22,BZR22)    !   BIRKELAND FIELD (TWO MODES FOR R1 AND TWO MODES FOR R2)
      ELSE
         BXR11=0.D0
         BYR11=0.D0
         BZR11=0.D0
         BXR12=0.D0
         BYR12=0.D0
         BZR12=0.D0
         BXR21=0.D0
         BYR21=0.D0
         BZR21=0.D0
         BXR22=0.D0
         BYR22=0.D0
         BZR22=0.D0
      ENDIF

      IF (IOPGEN.EQ.0.OR.IOPGEN.EQ.4) THEN
         PHI=1.5707963D0*DTANH(DABS(DST)/A(34))
         ZNAM=DABS(DST)
         IF (ZNAM.LT.20.D0) ZNAM=20.D0
         SC_SY=A(30)*(20.D0/ZNAM)**A(31) *XAPPA    !
         SC_AS=A(32)*(20.D0/ZNAM)**A(33) *XAPPA
         CALL FULL_RC(IOPR,PS,XX,YY,ZZ,BXSRC,BYSRC,BZSRC,BXPRC,BYPRC, &
                                              BZPRC)  !  SHIELDED RING CURRENT (SRC AND PRC)
      ELSE
         BXSRC=0.D0
         BYSRC=0.D0
         BZSRC=0.D0
         BXPRC=0.D0
         BYPRC=0.D0
         BZPRC=0.D0
      ENDIF
!
      IF (IOPGEN.EQ.0.OR.IOPGEN.EQ.5) THEN
         HXIMF=0.D0
         HYIMF=BYIMF
         HZIMF=BZIMF   ! THESE ARE COMPONENTS OF THE PENETRATED FIELD PER UNIT OF THE PENETRATION COEFFICIENT.
!                        IN OTHER WORDS, THESE ARE DERIVATIVES OF THE PENETRATION FIELD COMPONENTS WITH RESPECT
!                        TO THE PENETRATION COEFFICIENT.   WE ASSUME THAT ONLY THE TRANSVERSE COMPONENT OF THE
!                        FIELD PENETRATES INSIDE.
       ELSE
         HXIMF=0.D0
         HYIMF=0.D0
         HZIMF=0.D0
       ENDIF
!
!-----------------------------------------------------------
!
!    NOW, ADD UP ALL THE COMPONENTS:

      DLP1=(PDYN/2.D0)**A(42)
      DLP2=(PDYN/2.D0)**A(43)

      TAMP1=A(2)+A(3)*DLP1+A(4)*VBIMF1+A(5)*DST
      TAMP2=A(6)+A(7)*DLP2+A(8)*VBIMF1+A(9)*DST
      A_SRC=A(10)+A(11)*DST+A(12)*DSQRT(PDYN)
      A_PRC=A(13)+A(14)*DST+A(15)*DSQRT(PDYN)
      A_R11=A(16)+A(17)*VBIMF2
      A_R12=A(18)+A(19)*VBIMF2
      A_R21=A(20)+A(21)*VBIMF2
      A_R22=A(22)+A(23)*VBIMF2

      BBX=A(1)*BXCF+TAMP1*BXT1+TAMP2*BXT2+A_SRC*BXSRC+A_PRC*BXPRC &
       +A_R11*BXR11+A_R12*BXR12+A_R21*BXR21+A_R22*BXR22 &
         +A(24)*HXIMF+A(25)*HXIMF*STHETAH

      BBY=A(1)*BYCF+TAMP1*BYT1+TAMP2*BYT2+A_SRC*BYSRC+A_PRC*BYPRC &
       +A_R11*BYR11+A_R12*BYR12+A_R21*BYR21+A_R22*BYR22 &
         +A(24)*HYIMF+A(25)*HYIMF*STHETAH

      BBZ=A(1)*BZCF+TAMP1*BZT1+TAMP2*BZT2+A_SRC*BZSRC+A_PRC*BZPRC &
       +A_R11*BZR11+A_R12*BZR12+A_R21*BZR21+A_R22*BZR22 &
         +A(24)*HZIMF+A(25)*HZIMF*STHETAH

!
!   AND WE HAVE THE TOTAL EXTERNAL FIELD.
!
!  NOW, LET US CHECK WHETHER WE HAVE THE CASE (1). IF YES - WE ARE DONE:
!
      IF (SIGMA.LT.S0-DSIG) THEN    !  (X,Y,Z) IS INSIDE THE MAGNETOSPHERE
!-------------------------------------------------------------------------
       BX=BBX
       BY=BBY
       BZ=BBZ
!-------------------------------------------------------------------------
                     ELSE           !  THIS IS THE MOST COMPLEX CASE: WE ARE INSIDE
!                                             THE INTERPOLATION REGION
       FINT=0.5d0*(1.d0-(SIGMA-S0)/DSIG)
       FEXT=0.5d0*(1.d0+(SIGMA-S0)/DSIG)
!
       CALL DIPOLE (PS,X,Y,Z,QX,QY,QZ)
       BX=(BBX+QX)*FINT+OIMFX*FEXT -QX
       BY=(BBY+QY)*FINT+OIMFY*FEXT -QY
       BZ=(BBZ+QZ)*FINT+OIMFZ*FEXT -QZ
!
        ENDIF  !   THE CASES (1) AND (2) ARE EXHAUSTED; THE ONLY REMAINING
!                      POSSIBILITY IS NOW THE CASE (3):
!--------------------------------------------------------------------------
        ELSE
                CALL DIPOLE (PS,X,Y,Z,QX,QY,QZ)
                BX=OIMFX-QX
                BY=OIMFY-QY
                BZ=OIMFZ-QZ
        ENDIF
!
      END
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
         SUBROUTINE  SHLCAR3X3(X,Y,Z,PS,BX,BY,BZ)
!
!   THIS S/R RETURNS THE SHIELDING FIELD FOR THE EARTH'S DIPOLE,
!   REPRESENTED BY  2x3x3=18 "CARTESIAN" HARMONICS, tilted with respect
!   to the z=0 plane  (NB#4, p.74)
!
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  The 36 coefficients enter in pairs in the amplitudes of the "cartesian"
!    harmonics (A(1)-A(36).
!  The 14 nonlinear parameters (A(37)-A(50) are the scales Pi,Ri,Qi,and Si
!   entering the arguments of exponents, sines, and cosines in each of the
!   18 "Cartesian" harmonics  PLUS TWO TILT ANGLES FOR THE CARTESIAN HARMONICS
!       (ONE FOR THE PSI=0 MODE AND ANOTHER FOR THE PSI=90 MODE)
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!
      IMPLICIT  REAL * 8  (A - H, O - Z)
!
      DIMENSION A(50)
      save
      DATA A/-901.2327248d0,895.8011176d0,817.6208321d0,-845.5880889d0, &
      -83.73539535d0,86.58542841d0,336.8781402d0,-329.3619944d0,-311.2947120d0, &
      308.6011161d0,31.94469304d0,-31.30824526d0,125.8739681d0,-372.3384278d0, &
      -235.4720434d0,286.7594095d0,21.86305585d0,-27.42344605d0,-150.4874688d0, &
      2.669338538d0,1.395023949d0,-.5540427503d0,-56.85224007d0,3.681827033d0, &
      -43.48705106d0,5.103131905d0,1.073551279d0,-.6673083508d0,12.21404266d0, &
      4.177465543d0,5.799964188d0,-.3977802319d0,-1.044652977d0,.5703560010d0, &
      3.536082962d0,-3.222069852d0,9.620648151d0,6.082014949d0,27.75216226d0, &
      12.44199571d0,5.122226936d0,6.982039615d0,20.12149582d0,6.150973118d0, &
      4.663639687d0,15.73319647d0,2.303504968d0,5.840511214d0,.8385953499d-01, &
      .3477844929d0/
!
       P1=A(37)
       P2=A(38)
       P3=A(39)
       R1=A(40)
       R2=A(41)
       R3=A(42)
       Q1=A(43)
       Q2=A(44)
       Q3=A(45)
       S1=A(46)
       S2=A(47)
       S3=A(48)

       T1 =A(49)
       T2 =A(50)
!
       CPS=DCOS(PS)
       SPS=DSIN(PS)
       S2PS=2.D0*CPS      !   MODIFIED HERE (SIN(2*PS) INSTEAD OF SIN(3*PS))
!
       ST1=DSIN(PS*T1)
       CT1=DCOS(PS*T1)
       ST2=DSIN(PS*T2)
       CT2=DCOS(PS*T2)

       X1=X*CT1-Z*ST1
       Z1=X*ST1+Z*CT1
       X2=X*CT2-Z*ST2
       Z2=X*ST2+Z*CT2
!
!
!  MAKE THE TERMS IN THE 1ST SUM ("PERPENDICULAR" SYMMETRY):
!
!       I=1:
!
       SQPR= DSQRT(1.D0/P1**2+1.D0/R1**2)
       CYP = DCOS(Y/P1)
       SYP = DSIN(Y/P1)
       CZR = DCOS(Z1/R1)
       SZR = DSIN(Z1/R1)
       EXPR= DEXP(SQPR*X1)
       FX1 =-SQPR*EXPR*CYP*SZR
       HY1 = EXPR/P1*SYP*SZR
       FZ1 =-EXPR*CYP/R1*CZR
       HX1 = FX1*CT1+FZ1*ST1
       HZ1 =-FX1*ST1+FZ1*CT1

       SQPR= DSQRT(1.D0/P1**2+1.D0/R2**2)
       CYP = DCOS(Y/P1)
       SYP = DSIN(Y/P1)
       CZR = DCOS(Z1/R2)
       SZR = DSIN(Z1/R2)
       EXPR= DEXP(SQPR*X1)
       FX2 =-SQPR*EXPR*CYP*SZR
       HY2 = EXPR/P1*SYP*SZR
       FZ2 =-EXPR*CYP/R2*CZR
       HX2 = FX2*CT1+FZ2*ST1
       HZ2 =-FX2*ST1+FZ2*CT1

       SQPR= DSQRT(1.D0/P1**2+1.D0/R3**2)
       CYP = DCOS(Y/P1)
       SYP = DSIN(Y/P1)
       CZR = DCOS(Z1/R3)
       SZR = DSIN(Z1/R3)
       EXPR= DEXP(SQPR*X1)
       FX3 =-EXPR*CYP*(SQPR*Z1*CZR+SZR/R3*(X1+1.D0/SQPR))
       HY3 = EXPR/P1*SYP*(Z1*CZR+X1/R3*SZR/SQPR)
       FZ3 =-EXPR*CYP*(CZR*(1.D0+X1/R3**2/SQPR)-Z1/R3*SZR)
       HX3 = FX3*CT1+FZ3*ST1
       HZ3 =-FX3*ST1+FZ3*CT1
!
!       I=2:
!
       SQPR= DSQRT(1.D0/P2**2+1.D0/R1**2)
       CYP = DCOS(Y/P2)
       SYP = DSIN(Y/P2)
       CZR = DCOS(Z1/R1)
       SZR = DSIN(Z1/R1)
       EXPR= DEXP(SQPR*X1)
       FX4 =-SQPR*EXPR*CYP*SZR
       HY4 = EXPR/P2*SYP*SZR
       FZ4 =-EXPR*CYP/R1*CZR
       HX4 = FX4*CT1+FZ4*ST1
       HZ4 =-FX4*ST1+FZ4*CT1

       SQPR= DSQRT(1.D0/P2**2+1.D0/R2**2)
       CYP = DCOS(Y/P2)
       SYP = DSIN(Y/P2)
       CZR = DCOS(Z1/R2)
       SZR = DSIN(Z1/R2)
       EXPR= DEXP(SQPR*X1)
       FX5 =-SQPR*EXPR*CYP*SZR
       HY5 = EXPR/P2*SYP*SZR
       FZ5 =-EXPR*CYP/R2*CZR
       HX5 = FX5*CT1+FZ5*ST1
       HZ5 =-FX5*ST1+FZ5*CT1

       SQPR= DSQRT(1.D0/P2**2+1.D0/R3**2)
       CYP = DCOS(Y/P2)
       SYP = DSIN(Y/P2)
       CZR = DCOS(Z1/R3)
       SZR = DSIN(Z1/R3)
       EXPR= DEXP(SQPR*X1)
       FX6 =-EXPR*CYP*(SQPR*Z1*CZR+SZR/R3*(X1+1.D0/SQPR))
       HY6 = EXPR/P2*SYP*(Z1*CZR+X1/R3*SZR/SQPR)
       FZ6 =-EXPR*CYP*(CZR*(1.D0+X1/R3**2/SQPR)-Z1/R3*SZR)
       HX6 = FX6*CT1+FZ6*ST1
       HZ6 =-FX6*ST1+FZ6*CT1
!
!      I=3:
!
       SQPR= DSQRT(1.D0/P3**2+1.D0/R1**2)
       CYP = DCOS(Y/P3)
       SYP = DSIN(Y/P3)
       CZR = DCOS(Z1/R1)
       SZR = DSIN(Z1/R1)
       EXPR= DEXP(SQPR*X1)
       FX7 =-SQPR*EXPR*CYP*SZR
       HY7 = EXPR/P3*SYP*SZR
       FZ7 =-EXPR*CYP/R1*CZR
       HX7 = FX7*CT1+FZ7*ST1
       HZ7 =-FX7*ST1+FZ7*CT1

       SQPR= DSQRT(1.D0/P3**2+1.D0/R2**2)
       CYP = DCOS(Y/P3)
       SYP = DSIN(Y/P3)
       CZR = DCOS(Z1/R2)
       SZR = DSIN(Z1/R2)
       EXPR= DEXP(SQPR*X1)
       FX8 =-SQPR*EXPR*CYP*SZR
       HY8 = EXPR/P3*SYP*SZR
       FZ8 =-EXPR*CYP/R2*CZR
       HX8 = FX8*CT1+FZ8*ST1
       HZ8 =-FX8*ST1+FZ8*CT1

       SQPR= DSQRT(1.D0/P3**2+1.D0/R3**2)
       CYP = DCOS(Y/P3)
       SYP = DSIN(Y/P3)
       CZR = DCOS(Z1/R3)
       SZR = DSIN(Z1/R3)
       EXPR= DEXP(SQPR*X1)
       FX9 =-EXPR*CYP*(SQPR*Z1*CZR+SZR/R3*(X1+1.D0/SQPR))
       HY9 = EXPR/P3*SYP*(Z1*CZR+X1/R3*SZR/SQPR)
       FZ9 =-EXPR*CYP*(CZR*(1.D0+X1/R3**2/SQPR)-Z1/R3*SZR)
       HX9 = FX9*CT1+FZ9*ST1
       HZ9 =-FX9*ST1+FZ9*CT1
!
       A1=A(1)+A(2)*CPS
       A2=A(3)+A(4)*CPS
       A3=A(5)+A(6)*CPS
       A4=A(7)+A(8)*CPS
       A5=A(9)+A(10)*CPS
       A6=A(11)+A(12)*CPS
       A7=A(13)+A(14)*CPS
       A8=A(15)+A(16)*CPS
       A9=A(17)+A(18)*CPS
       BX=A1*HX1+A2*HX2+A3*HX3+A4*HX4+A5*HX5+A6*HX6+A7*HX7+A8*HX8+A9*HX9
       BY=A1*HY1+A2*HY2+A3*HY3+A4*HY4+A5*HY5+A6*HY6+A7*HY7+A8*HY8+A9*HY9
       BZ=A1*HZ1+A2*HZ2+A3*HZ3+A4*HZ4+A5*HZ5+A6*HZ6+A7*HZ7+A8*HZ8+A9*HZ9


!  MAKE THE TERMS IN THE 2ND SUM ("PARALLEL" SYMMETRY):
!
!       I=1
!
       SQQS= DSQRT(1.D0/Q1**2+1.D0/S1**2)
       CYQ = DCOS(Y/Q1)
       SYQ = DSIN(Y/Q1)
       CZS = DCOS(Z2/S1)
       SZS = DSIN(Z2/S1)
       EXQS= DEXP(SQQS*X2)
       FX1 =-SQQS*EXQS*CYQ*CZS *SPS
       HY1 = EXQS/Q1*SYQ*CZS   *SPS
       FZ1 = EXQS*CYQ/S1*SZS   *SPS
       HX1 = FX1*CT2+FZ1*ST2
       HZ1 =-FX1*ST2+FZ1*CT2

       SQQS= DSQRT(1.D0/Q1**2+1.D0/S2**2)
       CYQ = DCOS(Y/Q1)
       SYQ = DSIN(Y/Q1)
       CZS = DCOS(Z2/S2)
       SZS = DSIN(Z2/S2)
       EXQS= DEXP(SQQS*X2)
       FX2 =-SQQS*EXQS*CYQ*CZS *SPS
       HY2 = EXQS/Q1*SYQ*CZS   *SPS
       FZ2 = EXQS*CYQ/S2*SZS   *SPS
       HX2 = FX2*CT2+FZ2*ST2
       HZ2 =-FX2*ST2+FZ2*CT2

       SQQS= DSQRT(1.D0/Q1**2+1.D0/S3**2)
       CYQ = DCOS(Y/Q1)
       SYQ = DSIN(Y/Q1)
       CZS = DCOS(Z2/S3)
       SZS = DSIN(Z2/S3)
       EXQS= DEXP(SQQS*X2)
       FX3 =-SQQS*EXQS*CYQ*CZS *SPS
       HY3 = EXQS/Q1*SYQ*CZS   *SPS
       FZ3 = EXQS*CYQ/S3*SZS   *SPS
       HX3 = FX3*CT2+FZ3*ST2
       HZ3 =-FX3*ST2+FZ3*CT2
!
!       I=2:
!
       SQQS= DSQRT(1.D0/Q2**2+1.D0/S1**2)
       CYQ = DCOS(Y/Q2)
       SYQ = DSIN(Y/Q2)
       CZS = DCOS(Z2/S1)
       SZS = DSIN(Z2/S1)
       EXQS= DEXP(SQQS*X2)
       FX4 =-SQQS*EXQS*CYQ*CZS *SPS
       HY4 = EXQS/Q2*SYQ*CZS   *SPS
       FZ4 = EXQS*CYQ/S1*SZS   *SPS
       HX4 = FX4*CT2+FZ4*ST2
       HZ4 =-FX4*ST2+FZ4*CT2

       SQQS= DSQRT(1.D0/Q2**2+1.D0/S2**2)
       CYQ = DCOS(Y/Q2)
       SYQ = DSIN(Y/Q2)
       CZS = DCOS(Z2/S2)
       SZS = DSIN(Z2/S2)
       EXQS= DEXP(SQQS*X2)
       FX5 =-SQQS*EXQS*CYQ*CZS *SPS
       HY5 = EXQS/Q2*SYQ*CZS   *SPS
       FZ5 = EXQS*CYQ/S2*SZS   *SPS
       HX5 = FX5*CT2+FZ5*ST2
       HZ5 =-FX5*ST2+FZ5*CT2

       SQQS= DSQRT(1.D0/Q2**2+1.D0/S3**2)
       CYQ = DCOS(Y/Q2)
       SYQ = DSIN(Y/Q2)
       CZS = DCOS(Z2/S3)
       SZS = DSIN(Z2/S3)
       EXQS= DEXP(SQQS*X2)
       FX6 =-SQQS*EXQS*CYQ*CZS *SPS
       HY6 = EXQS/Q2*SYQ*CZS   *SPS
       FZ6 = EXQS*CYQ/S3*SZS   *SPS
       HX6 = FX6*CT2+FZ6*ST2
       HZ6 =-FX6*ST2+FZ6*CT2
!
!       I=3:
!
       SQQS= DSQRT(1.D0/Q3**2+1.D0/S1**2)
       CYQ = DCOS(Y/Q3)
       SYQ = DSIN(Y/Q3)
       CZS = DCOS(Z2/S1)
       SZS = DSIN(Z2/S1)
       EXQS= DEXP(SQQS*X2)
       FX7 =-SQQS*EXQS*CYQ*CZS *SPS
       HY7 = EXQS/Q3*SYQ*CZS   *SPS
       FZ7 = EXQS*CYQ/S1*SZS   *SPS
       HX7 = FX7*CT2+FZ7*ST2
       HZ7 =-FX7*ST2+FZ7*CT2

       SQQS= DSQRT(1.D0/Q3**2+1.D0/S2**2)
       CYQ = DCOS(Y/Q3)
       SYQ = DSIN(Y/Q3)
       CZS = DCOS(Z2/S2)
       SZS = DSIN(Z2/S2)
       EXQS= DEXP(SQQS*X2)
       FX8 =-SQQS*EXQS*CYQ*CZS *SPS
       HY8 = EXQS/Q3*SYQ*CZS   *SPS
       FZ8 = EXQS*CYQ/S2*SZS   *SPS
       HX8 = FX8*CT2+FZ8*ST2
       HZ8 =-FX8*ST2+FZ8*CT2

       SQQS= DSQRT(1.D0/Q3**2+1.D0/S3**2)
       CYQ = DCOS(Y/Q3)
       SYQ = DSIN(Y/Q3)
       CZS = DCOS(Z2/S3)
       SZS = DSIN(Z2/S3)
       EXQS= DEXP(SQQS*X2)
       FX9 =-SQQS*EXQS*CYQ*CZS *SPS
       HY9 = EXQS/Q3*SYQ*CZS   *SPS
       FZ9 = EXQS*CYQ/S3*SZS   *SPS
       HX9 = FX9*CT2+FZ9*ST2
       HZ9 =-FX9*ST2+FZ9*CT2

       A1=A(19)+A(20)*S2PS
       A2=A(21)+A(22)*S2PS
       A3=A(23)+A(24)*S2PS
       A4=A(25)+A(26)*S2PS
       A5=A(27)+A(28)*S2PS
       A6=A(29)+A(30)*S2PS
       A7=A(31)+A(32)*S2PS
       A8=A(33)+A(34)*S2PS
       A9=A(35)+A(36)*S2PS

       BX=BX+A1*HX1+A2*HX2+A3*HX3+A4*HX4+A5*HX5+A6*HX6+A7*HX7+A8*HX8 &
         +A9*HX9
       BY=BY+A1*HY1+A2*HY2+A3*HY3+A4*HY4+A5*HY5+A6*HY6+A7*HY7+A8*HY8 &
         +A9*HY9
       BZ=BZ+A1*HZ1+A2*HZ2+A3*HZ3+A4*HZ4+A5*HZ5+A6*HZ6+A7*HZ7+A8*HZ8 &
         +A9*HZ9
!
       RETURN
       END
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
      SUBROUTINE DEFORMED (IOPT,PS,X,Y,Z,BX1,BY1,BZ1,BX2,BY2,BZ2)
!
!   IOPT - TAIL FIELD MODE FLAG:   IOPT=0 - THE TWO TAIL MODES ARE ADDED UP
!                                  IOPT=1 - MODE 1 ONLY
!                                  IOPT=2 - MODE 2 ONLY
!
!   CALCULATES GSM COMPONENTS OF TWO UNIT-AMPLITUDE TAIL FIELD MODES,
!    TAKING INTO ACCOUNT BOTH EFFECTS OF DIPOLE TILT:
!    WARPING IN Y-Z (DONE BY THE S/R WARPED) AND BENDING IN X-Z (DONE BY THIS SUBROUTINE)
!
      IMPLICIT REAL*8 (A-H,O-Z)
      save
      COMMON /RH0/ RH0
      DATA RH2,IEPS /-5.2D0,3/
!
!  RH0,RH1,RH2, AND IEPS CONTROL THE TILT-RELATED DEFORMATION OF THE TAIL FIELD
!
      SPS=DSIN(PS)
! jah, foresys : Result of assignment to CPS is not used
! jah,      CPS=DSQRT(1.D0-SPS**2)
      R2=X**2+Y**2+Z**2
      R=SQRT(R2)
      ZR=Z/R
      RH=RH0+RH2*ZR**2
      DRHDR=-ZR/R*2.D0*RH2*ZR
      DRHDZ= 2.D0*RH2*ZR/R
!
      RRH=R/RH
      F=1.D0/(1.D0+RRH**dble(IEPS))**(1.D0/dble(IEPS))
      DFDR=-RRH**(IEPS-1)*F**(IEPS+1)/RH
      DFDRH=-RRH*DFDR
!
      SPSAS=SPS*F
      CPSAS=DSQRT(1.D0-SPSAS**2)
!
      XAS=X*CPSAS-Z*SPSAS
      ZAS=X*SPSAS+Z*CPSAS
!
      FACPS=SPS/CPSAS*(DFDR+DFDRH*DRHDR)/R
      PSASX=FACPS*X
      PSASY=FACPS*Y
      PSASZ=FACPS*Z+SPS/CPSAS*DFDRH*DRHDZ
!
      DXASDX=CPSAS-ZAS*PSASX
      DXASDY=-ZAS*PSASY
      DXASDZ=-SPSAS-ZAS*PSASZ
      DZASDX=SPSAS+XAS*PSASX
      DZASDY=XAS*PSASY
      DZASDZ=CPSAS+XAS*PSASZ
      FAC1=DXASDZ*DZASDY-DXASDY*DZASDZ
      FAC2=DXASDX*DZASDZ-DXASDZ*DZASDX
      FAC3=DZASDX*DXASDY-DXASDX*DZASDY
!
!     DEFORM:
!
      CALL WARPED(IOPT,PS,XAS,Y,ZAS,BXAS1,BYAS1,BZAS1,BXAS2,BYAS2,BZAS2)
!
      BX1=BXAS1*DZASDZ-BZAS1*DXASDZ +BYAS1*FAC1
      BY1=BYAS1*FAC2
      BZ1=BZAS1*DXASDX-BXAS1*DZASDX +BYAS1*FAC3

      BX2=BXAS2*DZASDZ-BZAS2*DXASDZ +BYAS2*FAC1
      BY2=BYAS2*FAC2
      BZ2=BZAS2*DXASDX-BXAS2*DZASDX +BYAS2*FAC3

      RETURN
      END
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
      SUBROUTINE WARPED (IOPT,PS,X,Y,Z,BX1,BY1,BZ1,BX2,BY2,BZ2)
!
!   CALCULATES GSM COMPONENTS OF THE WARPED FIELD FOR TWO TAIL UNIT MODES.
!   THE WARPING DEFORMATION IS IMPOSED ON THE UNWARPED FIELD, COMPUTED
!   BY THE S/R "UNWARPED".  THE WARPING PARAMETER G WAS OBTAINED BY LEAST
!   SQUARES FITTING TO THE ENTIRE DATASET.
!
!   IOPT - TAIL FIELD MODE FLAG:   IOPT=0 - THE TWO TAIL MODES ARE ADDED UP
!                                  IOPT=1 - MODE 1 ONLY
!                                  IOPT=2 - MODE 2 ONLY
!
      IMPLICIT REAL*8 (A-H,O-Z)
      save
!
      COMMON /G/ G
      DGDX=0.D0
      XL=20.D0
      DXLDX=0.D0

      SPS=DSIN(PS)
      RHO2=Y**2+Z**2
      RHO=DSQRT(RHO2)

      IF (Y.EQ.0.D0.AND.Z.EQ.0.D0) THEN
       PHI=0.D0
       CPHI=1.D0
       SPHI=0.D0
      ELSE
       PHI=DATAN2(Z,Y)
       CPHI=Y/RHO
       SPHI=Z/RHO
      ENDIF

      RR4L4=RHO/(RHO2**2+XL**4)

      F=PHI+G*RHO2*RR4L4*CPHI*SPS
      DFDPHI=1.D0-G*RHO2*RR4L4*SPHI*SPS
      DFDRHO=G*RR4L4**2*(3.D0*XL**4-RHO2**2)*CPHI*SPS
      DFDX=RR4L4*CPHI*SPS*(DGDX*RHO2-G*RHO*RR4L4*4.D0*XL**3*DXLDX)

      CF=DCOS(F)
      SF=DSIN(F)
      YAS=RHO*CF
      ZAS=RHO*SF

      CALL UNWARPED (IOPT,X,YAS,ZAS,BX_AS1,BY_AS1,BZ_AS1, &
        BX_AS2,BY_AS2,BZ_AS2)

      BRHO_AS =  BY_AS1*CF+BZ_AS1*SF      !   DEFORM THE 1ST MODE
      BPHI_AS = -BY_AS1*SF+BZ_AS1*CF

      BRHO_S = BRHO_AS*DFDPHI
      BPHI_S = BPHI_AS-RHO*(BX_AS1*DFDX+BRHO_AS*DFDRHO)
      BX1    = BX_AS1*DFDPHI

      BY1    = BRHO_S*CPHI-BPHI_S*SPHI
      BZ1    = BRHO_S*SPHI+BPHI_S*CPHI    !   DONE

      BRHO_AS =  BY_AS2*CF+BZ_AS2*SF      !   DEFORM THE 2ND MODE
      BPHI_AS = -BY_AS2*SF+BZ_AS2*CF

      BRHO_S = BRHO_AS*DFDPHI
      BPHI_S = BPHI_AS-RHO*(BX_AS2*DFDX+BRHO_AS*DFDRHO)
      BX2    = BX_AS2*DFDPHI

      BY2    = BRHO_S*CPHI-BPHI_S*SPHI
      BZ2    = BRHO_S*SPHI+BPHI_S*CPHI    !   DONE

      RETURN
      END
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
       SUBROUTINE UNWARPED (IOPT,X,Y,Z,BX1,BY1,BZ1,BX2,BY2,BZ2)

!   IOPT - TAIL FIELD MODE FLAG:   IOPT=0 - THE TWO TAIL MODES ARE ADDED UP
!                                  IOPT=1 - MODE 1 ONLY
!                                  IOPT=2 - MODE 2 ONLY
!
!    CALCULATES GSM COMPONENTS OF THE SHIELDED FIELD OF TWO TAIL MODES WITH UNIT
!    AMPLITUDES,  WITHOUT ANY WARPING OR BENDING.  NONLINEAR PARAMETERS OF THE MODES
!    ARE FORWARDED HERE VIA A COMMON BLOCK /TAIL/.
!
      IMPLICIT REAL*8 (A-H,O-Z)
      save
!
      DIMENSION A1(60),A2(60)  !   TAIL SHIELDING FIELD PARAMETERS FOR THE MODES #1 & #2

      COMMON /TAIL/ DXSHIFT1,DXSHIFT2,D0,DELTADY
!
      DATA DELTADX1,ALPHA1,XSHIFT1 /1.D0,1.1D0,6.D0/
      DATA DELTADX2,ALPHA2,XSHIFT2 /0.D0,.25D0,4.D0/

      DATA A1/-25.45869857d0,57.35899080d0,317.5501869d0,-2.626756717d0, &
      -93.38053698d0,-199.6467926d0,-858.8129729d0,34.09192395d0,845.4214929d0, &
      -29.07463068d0,47.10678547d0,-128.9797943d0,-781.7512093d0,6.165038619d0, &
      167.8905046d0,492.0680410d0,1654.724031d0,-46.77337920d0,-1635.922669d0, &
      40.86186772d0,-.1349775602d0,-.9661991179d-01,-.1662302354d0, &
      .002810467517d0,.2487355077d0,.1025565237d0,-14.41750229d0,-.8185333989d0, &
      11.07693629d0,.7569503173d0,-9.655264745d0,112.2446542d0,777.5948964d0, &
      -5.745008536d0,-83.03921993d0,-490.2278695d0,-1155.004209d0,39.08023320d0, &
      1172.780574d0,-39.44349797d0,-14.07211198d0,-40.41201127d0,-313.2277343d0, &
      2.203920979d0,8.232835341d0,197.7065115d0,391.2733948d0,-18.57424451d0, &
      -437.2779053d0,23.04976898d0,11.75673963d0,13.60497313d0,4.691927060d0, &
      18.20923547d0,27.59044809d0,6.677425469d0,1.398283308d0,2.839005878d0, &
      31.24817706d0,24.53577264d0/

      DATA A2/-287187.1962d0,4970.499233d0,410490.1952d0,-1347.839052d0, &
      -386370.3240d0,3317.983750d0,-143462.3895d0,5706.513767d0,171176.2904d0, &
      250.8882750d0,-506570.8891d0,5733.592632d0,397975.5842d0,9771.762168d0, &
      -941834.2436d0,7990.975260d0,54313.10318d0,447.5388060d0,528046.3449d0, &
      12751.04453d0,-21920.98301d0,-21.05075617d0,31971.07875d0,3012.641612d0, &
      -301822.9103d0,-3601.107387d0,1797.577552d0,-6.315855803d0,142578.8406d0, &
      13161.93640d0,804184.8410d0,-14168.99698d0,-851926.6360d0,-1890.885671d0, &
      972475.6869d0,-8571.862853d0,26432.49197d0,-2554.752298d0,-482308.3431d0, &
      -4391.473324d0,105155.9160d0,-1134.622050d0,-74353.53091d0,-5382.670711d0, &
      695055.0788d0,-916.3365144d0,-12111.06667d0,67.20923358d0,-367200.9285d0, &
      -21414.14421d0,14.75567902d0,20.75638190d0,59.78601609d0,16.86431444d0, &
      32.58482365d0,23.69472951d0,17.24977936d0,13.64902647d0,68.40989058d0, &
      11.67828167d0/

      DATA XM1,XM2/2*-12.D0/

      IF (IOPT.EQ.2) GOTO 1

      XSC1=(X-XSHIFT1-DXSHIFT1)*ALPHA1-XM1*(ALPHA1-1.D0)
      YSC1=Y*ALPHA1
      ZSC1=Z*ALPHA1
      D0SC1=D0*ALPHA1   ! HERE WE USE A SINGLE VALUE D0 OF THE THICKNESS FOR BOTH MODES

      CALL TAILDISK(D0SC1,DELTADX1,DELTADY,XSC1,YSC1,ZSC1,FX1,FY1,FZ1)
      CALL SHLCAR5X5(A1,X,Y,Z,DXSHIFT1,HX1,HY1,HZ1)

      BX1=FX1+HX1
      BY1=FY1+HY1
      BZ1=FZ1+HZ1

      IF (IOPT.EQ.1) THEN
        BX2=0.D0
        BY2=0.D0
        BZ2=0.D0
        RETURN
      ENDIF

 1    XSC2=(X-XSHIFT2-DXSHIFT2)*ALPHA2-XM2*(ALPHA2-1.D0)
      YSC2=Y*ALPHA2
      ZSC2=Z*ALPHA2
      D0SC2=D0*ALPHA2   ! HERE WE USE A SINGLE VALUE D0 OF THE THICKNESS FOR BOTH MODES

      CALL TAILDISK(D0SC2,DELTADX2,DELTADY,XSC2,YSC2,ZSC2,FX2,FY2,FZ2)
      CALL SHLCAR5X5(A2,X,Y,Z,DXSHIFT2,HX2,HY2,HZ2)

      BX2=FX2+HX2
      BY2=FY2+HY2
      BZ2=FZ2+HZ2

      IF (IOPT.EQ.2) THEN
        BX1=0.D0
        BY1=0.D0
        BZ1=0.D0
        RETURN
      ENDIF

      RETURN
      END
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
      SUBROUTINE TAILDISK(D0,DELTADX,DELTADY,X,Y,Z,BX,BY,BZ)
!
!       THIS SUBROUTINE COMPUTES THE COMPONENTS OF THE TAIL CURRENT FIELD,
!       SIMILAR TO THAT DESCRIBED BY TSYGANENKO AND PEREDO (1994).  THE
!       DIFFERENCE IS THAT NOW WE USE SPACEWARPING, AS DESCRIBED IN OUR
!       PAPER ON MODELING BIRKELAND CURRENTS (TSYGANENKO AND STERN, 1996)
!       INSTEAD OF SHEARING IT IN THE SPIRIT OF THE T89 TAIL MODEL.
!
      IMPLICIT REAL*8 (A-H,O-Z)
!
      DIMENSION F(5),B(5),C(5)
      save
!
      DATA F /-71.09346626D0,-1014.308601D0,-1272.939359D0, &
              -3224.935936D0,-44546.86232D0/
      DATA B /10.90101242D0,12.68393898D0,13.51791954D0,14.86775017D0, &
                15.12306404D0/
      DATA C /.7954069972D0,.6716601849D0,1.174866319D0,2.565249920D0, &
                10.01986790D0/
!
      RHO=DSQRT(X**2+Y**2)
      DRHODX=X/RHO
      DRHODY=Y/RHO

      DEX=DEXP(X/7.D0)
      D=D0+DELTADY*(Y/20.D0)**2  +DELTADX*DEX !   THE LAST TERM (INTRODUCED 10/11/2000) MAKES THE SHEET
      DDDY=DELTADY*Y*0.005D0                  !   THICKEN SUNWARD, TO AVOID PROBLEMS IN THE SUBSOLAR REGION
      DDDX=DELTADX/7.D0*DEX
!
      DZETA=DSQRT(Z**2+D**2)  !  THIS IS THE SAME SIMPLE WAY TO SPREAD
!                                        OUT THE SHEET, AS THAT USED IN T89
      DDZETADX=D*DDDX/DZETA
      DDZETADY=D*DDDY/DZETA
      DDZETADZ=Z/DZETA

!
      DBX=0.D0
      DBY=0.D0
      DBZ=0.D0
!
      DO 1 I=1,5
!
      BI=B(I)
      CI=C(I)
!
      S1=DSQRT((RHO+BI)**2+(DZETA+CI)**2)
      S2=DSQRT((RHO-BI)**2+(DZETA+CI)**2)

      DS1DRHO=(RHO+BI)/S1
      DS2DRHO=(RHO-BI)/S2
      DS1DDZ=(DZETA+CI)/S1
      DS2DDZ=(DZETA+CI)/S2
!
      DS1DX=DS1DRHO*DRHODX  +DS1DDZ*DDZETADX
      DS1DY=DS1DRHO*DRHODY  +   DS1DDZ*DDZETADY
      DS1DZ=                      DS1DDZ*DDZETADZ
!
      DS2DX=DS2DRHO*DRHODX  +DS2DDZ*DDZETADX
      DS2DY=DS2DRHO*DRHODY  +   DS2DDZ*DDZETADY
      DS2DZ=                    DS2DDZ*DDZETADZ
!
      S1TS2=S1*S2
      S1PS2=S1+S2
      S1PS2SQ=S1PS2**2

      FAC1=DSQRT(S1PS2SQ-(2.D0*BI)**2)
      AS=FAC1/(S1TS2*S1PS2SQ)
      DASDS1=(1.D0/(FAC1*S2)-AS/S1PS2*(S2*S2+S1*(3.D0*S1+4.D0*S2))) &
                /(S1*S1PS2)
      DASDS2=(1.D0/(FAC1*S1)-AS/S1PS2*(S1*S1+S2*(3.D0*S2+4.D0*S1))) &
                /(S2*S1PS2)
!
      DASDX=DASDS1*DS1DX+DASDS2*DS2DX
      DASDY=DASDS1*DS1DY+DASDS2*DS2DY
      DASDZ=DASDS1*DS1DZ+DASDS2*DS2DZ
!
      DBX=DBX-F(I)*X*DASDZ
      DBY=DBY-F(I)*Y*DASDZ
  1   DBZ=DBZ+F(I)*(2.D0*AS+X*DASDX+Y*DASDY)

      BX=DBX
      BY=DBY
      BZ=DBZ

      RETURN
      END
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
! THIS CODE RETURNS THE SHIELDING FIELD REPRESENTED BY  5x5=25 "CARTESIAN"
!    HARMONICS
!
         SUBROUTINE  SHLCAR5X5(A,X,Y,Z,DSHIFT,HX,HY,HZ)
!
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  The NLIN coefficients are the amplitudes of the "cartesian"
!    harmonics (A(1)-A(NLIN).
!  The NNP nonlinear parameters (A(NLIN+1)-A(NTOT) are the scales Pi and Ri
!   entering the arguments of exponents, sines, and cosines in each of the
!   NLIN "Cartesian" harmonics
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!
         IMPLICIT  REAL * 8  (A - H, O - Z)
!
         DIMENSION A(60)
      save
!
         DHX=0.D0
         DHY=0.D0
         DHZ=0.D0

         L=0
!
         DO 2 I=1,5
         RP=1.D0/A(50+I)
         CYPI=DCOS(Y*RP)
         SYPI=DSIN(Y*RP)
!
         DO 2 K=1,5
         RR=1.D0/A(55+K)
         SZRK=DSIN(Z*RR)
         CZRK=DCOS(Z*RR)
         SQPR=DSQRT(RP**2+RR**2)
         EPR=DEXP(X*SQPR)
!
         DBX=-SQPR*EPR*CYPI*SZRK
         DBY= RP*EPR*SYPI*SZRK
         DBZ=-RR*EPR*CYPI*CZRK

         L=L+2
         COEF=A(L-1)+A(L)*DSHIFT

         DHX=DHX+COEF*DBX
         DHY=DHY+COEF*DBY
         DHZ=DHZ+COEF*DBZ
!
  2      CONTINUE

         HX=DHX
         HY=DHY
         HZ=DHZ
!
      RETURN
      END
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
      SUBROUTINE BIRK_TOT (IOPB,PS,X,Y,Z,BX11,BY11,BZ11,BX12,BY12,BZ12, &
                                BX21,BY21,BZ21,BX22,BY22,BZ22)
!
!      IOPB -  BIRKELAND FIELD MODE FLAG:
!         IOPB=0 - ALL COMPONENTS
!         IOPB=1 - REGION 1, MODES 1 & 2
!         IOPB=2 - REGION 2, MODES 1 & 2
!
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION SH11(86),SH12(86),SH21(86),SH22(86)
      save
      COMMON /BIRKPAR/ XKAPPA1,XKAPPA2   !  INPUT PARAMETERS, SPECIFIED FROM S/R EXTALL
      COMMON /DPHI_B_RHO0/ DPHI,B,RHO_0,XKAPPA ! PARAMETERS, CONTROLLING THE DAY-NIGHT ASYMMETRY OF F.A.C.

      DATA SH11/46488.84663d0,-15541.95244d0,-23210.09824d0,-32625.03856d0, &
      -109894.4551d0,-71415.32808d0,58168.94612d0,55564.87578d0,-22890.60626d0, &
      -6056.763968d0,5091.368100d0,239.7001538d0,-13899.49253d0,4648.016991d0, &
      6971.310672d0,9699.351891d0,32633.34599d0,21028.48811d0,-17395.96190d0, &
      -16461.11037d0,7447.621471d0,2528.844345d0,-1934.094784d0,-588.3108359d0, &
      -32588.88216d0,10894.11453d0,16238.25044d0,22925.60557d0,77251.11274d0, &
      50375.97787d0,-40763.78048d0,-39088.60660d0,15546.53559d0,3559.617561d0, &
      -3187.730438d0,309.1487975d0,88.22153914d0,-243.0721938d0,-63.63543051d0, &
      191.1109142d0,69.94451996d0,-187.9539415d0,-49.89923833d0,104.0902848d0, &
      -120.2459738d0,253.5572433d0,89.25456949d0,-205.6516252d0,-44.93654156d0, &
      124.7026309d0,32.53005523d0,-98.85321751d0,-36.51904756d0,98.88241690d0, &
      24.88493459d0,-55.04058524d0,61.14493565d0,-128.4224895d0,-45.35023460d0, &
      105.0548704d0,-43.66748755d0,119.3284161d0,31.38442798d0,-92.87946767d0, &
      -33.52716686d0,89.98992001d0,25.87341323d0,-48.86305045d0,59.69362881d0, &
      -126.5353789d0,-44.39474251d0,101.5196856d0,59.41537992d0,41.18892281d0, &
      80.86101200d0,3.066809418d0,7.893523804d0,30.56212082d0,10.36861082d0, &
      8.222335945d0,19.97575641d0,2.050148531d0,4.992657093d0,2.300564232d0, &
      .2256245602d0,-.05841594319d0/

      DATA SH12/210260.4816d0,-1443587.401d0,-1468919.281d0,281939.2993d0, &
      -1131124.839d0,729331.7943d0,2573541.307d0,304616.7457d0,468887.5847d0, &
      181554.7517d0,-1300722.650d0,-257012.8601d0,645888.8041d0,-2048126.412d0, &
      -2529093.041d0,571093.7972d0,-2115508.353d0,1122035.951d0,4489168.802d0, &
      75234.22743d0,823905.6909d0,147926.6121d0,-2276322.876d0,-155528.5992d0, &
      -858076.2979d0,3474422.388d0,3986279.931d0,-834613.9747d0,3250625.781d0, &
      -1818680.377d0,-7040468.986d0,-414359.6073d0,-1295117.666d0,-346320.6487d0, &
      3565527.409d0,430091.9496d0,-.1565573462d0,7.377619826d0,.4115646037d0, &
      -6.146078880d0,3.808028815d0,-.5232034932d0,1.454841807d0,-12.32274869d0, &
      -4.466974237d0,-2.941184626d0,-.6172620658d0,12.64613490d0,1.494922012d0, &
      -21.35489898d0,-1.652256960d0,16.81799898d0,-1.404079922d0,-24.09369677d0, &
      -10.99900839d0,45.94237820d0,2.248579894d0,31.91234041d0,7.575026816d0, &
      -45.80833339d0,-1.507664976d0,14.60016998d0,1.348516288d0,-11.05980247d0, &
      -5.402866968d0,31.69094514d0,12.28261196d0,-37.55354174d0,4.155626879d0, &
      -33.70159657d0,-8.437907434d0,36.22672602d0,145.0262164d0,70.73187036d0, &
      85.51110098d0,21.47490989d0,24.34554406d0,31.34405345d0,4.655207476d0, &
      5.747889264d0,7.802304187d0,1.844169801d0,4.867254550d0,2.941393119d0, &
      .1379899178d0,.06607020029d0/

      DATA SH21/162294.6224d0,503885.1125d0,-27057.67122d0,-531450.1339d0, &
      84747.05678d0,-237142.1712d0,84133.61490d0,259530.0402d0,69196.05160d0, &
      -189093.5264d0,-19278.55134d0,195724.5034d0,-263082.6367d0,-818899.6923d0, &
      43061.10073d0,863506.6932d0,-139707.9428d0,389984.8850d0,-135167.5555d0, &
      -426286.9206d0,-109504.0387d0,295258.3531d0,30415.07087d0,-305502.9405d0, &
      100785.3400d0,315010.9567d0,-15999.50673d0,-332052.2548d0,54964.34639d0, &
      -152808.3750d0,51024.67566d0,166720.0603d0,40389.67945d0,-106257.7272d0, &
      -11126.14442d0,109876.2047d0,2.978695024d0,558.6019011d0,2.685592939d0, &
      -338.0004730d0,-81.99724090d0,-444.1102659d0,89.44617716d0,212.0849592d0, &
      -32.58562625d0,-982.7336105d0,-35.10860935d0,567.8931751d0,-1.917212423d0, &
      -260.2023543d0,-1.023821735d0,157.5533477d0,23.00200055d0,232.0603673d0, &
      -36.79100036d0,-111.9110936d0,18.05429984d0,447.0481000d0,15.10187415d0, &
      -258.7297813d0,-1.032340149d0,-298.6402478d0,-1.676201415d0,180.5856487d0, &
      64.52313024d0,209.0160857d0,-53.85574010d0,-98.52164290d0,14.35891214d0, &
      536.7666279d0,20.09318806d0,-309.7349530d0,58.54144539d0,67.45226850d0, &
      97.92374406d0,4.752449760d0,10.46824379d0,32.91856110d0,12.05124381d0, &
      9.962933904d0,15.91258637d0,1.804233877d0,6.578149088d0,2.515223491d0, &
      .1930034238d0,-.02261109942d0/

      DATA SH22/-131287.8986d0,-631927.6885d0,-318797.4173d0,616785.8782d0, &
      -50027.36189d0,863099.9833d0,47680.20240d0,-1053367.944d0,-501120.3811d0, &
      -174400.9476d0,222328.6873d0,333551.7374d0,-389338.7841d0,-1995527.467d0, &
      -982971.3024d0,1960434.268d0,297239.7137d0,2676525.168d0,-147113.4775d0, &
      -3358059.979d0,-2106979.191d0,-462827.1322d0,1017607.960d0,1039018.475d0, &
      520266.9296d0,2627427.473d0,1301981.763d0,-2577171.706d0,-238071.9956d0, &
      -3539781.111d0,94628.16420d0,4411304.724d0,2598205.733d0,637504.9351d0, &
      -1234794.298d0,-1372562.403d0,-2.646186796d0,-31.10055575d0,2.295799273d0, &
      19.20203279d0,30.01931202d0,-302.1028550d0,-14.78310655d0,162.1561899d0, &
      .4943938056d0,176.8089129d0,-.2444921680d0,-100.6148929d0,9.172262228d0, &
      137.4303440d0,-8.451613443d0,-84.20684224d0,-167.3354083d0,1321.830393d0, &
      76.89928813d0,-705.7586223d0,18.28186732d0,-770.1665162d0,-9.084224422d0, &
      436.3368157d0,-6.374255638d0,-107.2730177d0,6.080451222d0,65.53843753d0, &
      143.2872994d0,-1028.009017d0,-64.22739330d0,547.8536586d0,-20.58928632d0, &
      597.3893669d0,10.17964133d0,-337.7800252d0,159.3532209d0,76.34445954d0, &
      84.74398828d0,12.76722651d0,27.63870691d0,32.69873634d0,5.145153451d0, &
      6.310949163d0,6.996159733d0,1.971629939d0,4.436299219d0,2.904964304d0, &
      .1486276863d0,.06859991529d0/
!
      XKAPPA=XKAPPA1        !  FORWARDED IN BIRK_1N2
      X_SC=XKAPPA1-1.1D0    !  FORWARDED IN BIRK_SHL

      IF (IOPB.EQ.0.OR.IOPB.EQ.1) THEN

      CALL BIRK_1N2 (1,1,PS,X,Y,Z,FX11,FY11,FZ11)           !  REGION 1, MODE 1
      CALL BIRK_SHL (SH11,PS,X_SC,X,Y,Z,HX11,HY11,HZ11)
      BX11=FX11+HX11
      BY11=FY11+HY11
      BZ11=FZ11+HZ11

      CALL BIRK_1N2 (1,2,PS,X,Y,Z,FX12,FY12,FZ12)           !  REGION 1, MODE 2
      CALL BIRK_SHL (SH12,PS,X_SC,X,Y,Z,HX12,HY12,HZ12)
      BX12=FX12+HX12
      BY12=FY12+HY12
      BZ12=FZ12+HZ12

      ENDIF

      XKAPPA=XKAPPA2        !  FORWARDED IN BIRK_1N2
      X_SC=XKAPPA2-1.0D0    !  FORWARDED IN BIRK_SHL

      IF (IOPB.EQ.0.OR.IOPB.EQ.2) THEN

      CALL BIRK_1N2 (2,1,PS,X,Y,Z,FX21,FY21,FZ21)           !  REGION 2, MODE 1
      CALL BIRK_SHL (SH21,PS,X_SC,X,Y,Z,HX21,HY21,HZ21)
      BX21=FX21+HX21
      BY21=FY21+HY21
      BZ21=FZ21+HZ21

      CALL BIRK_1N2 (2,2,PS,X,Y,Z,FX22,FY22,FZ22)           !  REGION 2, MODE 2
      CALL BIRK_SHL (SH22,PS,X_SC,X,Y,Z,HX22,HY22,HZ22)
      BX22=FX22+HX22
      BY22=FY22+HY22
      BZ22=FZ22+HZ22

      ENDIF

      RETURN
      END
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
      SUBROUTINE BIRK_1N2 (NUMB,MODE,PS,X,Y,Z,BX,BY,BZ)        !   NB# 6, P.60
!
!  CALCULATES COMPONENTS  OF REGION 1/2 FIELD IN SPHERICAL COORDS.  DERIVED FROM THE S/R DIPDEF2C (WHICH
!    DOES THE SAME JOB, BUT INPUT/OUTPUT THERE WAS IN SPHERICAL COORDS, WHILE HERE WE USE CARTESIAN ONES)
!
!   INPUT:  NUMB=1 (2) FOR REGION 1 (2) CURRENTS
!           MODE=1 YIELDS SIMPLE SINUSOIDAL MLT VARIATION, WITH MAXIMUM CURRENT AT DAWN/DUSK MERIDIAN
!     WHILE MODE=2 YIELDS THE SECOND HARMONIC.
!
!
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION A11(31),A12(31),A21(31),A22(31)
      save
      COMMON /MODENUM/ M
      COMMON /DTHETA/ DTHETA

      COMMON /DPHI_B_RHO0/ DPHI,B,RHO_0,XKAPPA ! THESE PARAMETERS CONTROL DAY-NIGHT ASYMMETRY OF F.A.C., AS FOLLOWS:

!  (1) DPHI:   HALF-DIFFERENCE (IN RADIANS) BETWEEN DAY AND NIGHT LATITUDE OF FAC OVAL AT IONOSPHERIC ALTITUDE;
!              TYPICAL VALUE: 0.06
!  (2) B:      AN ASYMMETRY FACTOR AT HIGH-ALTITUDES;  FOR B=0, THE ONLY ASYMMETRY IS THAT FROM DPHI
!              TYPICAL VALUES: 0.35-0.70
!  (3) RHO_0:  A FIXED PARAMETER, DEFINING THE DISTANCE RHO, AT WHICH THE LATITUDE SHIFT GRADUALLY SATURATES AND
!              STOPS INCREASING
!              ITS VALUE WAS ASSUMED FIXED, EQUAL TO 7.0.
!  (4) XKAPPA: AN OVERALL SCALING FACTOR, WHICH CAN BE USED FOR CHANGING THE SIZE OF THE F.A.C. OVAL
!
      DATA BETA,RH,EPS/0.9D0,10.D0,3.D0/ ! parameters of the tilt-dependent deformation of the untilted F.A.C. field

      DATA A11/.1618068350d0,-.1797957553d0,2.999642482d0,-.9322708978d0, &
      -.6811059760d0,.2099057262d0,-8.358815746d0,-14.86033550d0,.3838362986d0, &
      -16.30945494d0,4.537022847d0,2.685836007d0,27.97833029d0,6.330871059d0, &
      1.876532361d0,18.95619213d0,.9651528100d0,.4217195118d0,-.08957770020d0, &
      -1.823555887d0,.7457045438d0,-.5785916524d0,-1.010200918d0,.01112389357d0, &
      .09572927448d0,-.3599292276d0,8.713700514d0,.9763932955d0,3.834602998d0, &
      2.492118385d0,.7113544659d0/
      DATA A12/.7058026940d0,-.2845938535d0,5.715471266d0,-2.472820880d0, &
      -.7738802408d0,.3478293930d0,-11.37653694d0,-38.64768867d0,.6932927651d0, &
      -212.4017288d0,4.944204937d0,3.071270411d0,33.05882281d0,7.387533799d0, &
      2.366769108d0,79.22572682d0,.6154290178d0,.5592050551d0,-.1796585105d0, &
      -1.654932210d0,.7309108776d0,-.4926292779d0,-1.130266095d0,-.009613974555d0, &
      .1484586169d0,-.2215347198d0,7.883592948d0,.02768251655d0,2.950280953d0, &
      1.212634762d0,.5567714182d0/
      DATA A21/.1278764024d0,-.2320034273d0,1.805623266d0,-32.37241440d0, &
      -.9931490648d0,.3175085630d0,-2.492465814d0,-16.21600096d0,.2695393416d0, &
      -6.752691265d0,3.971794901d0,14.54477563d0,41.10158386d0,7.912889730d0, &
      1.258297372d0,9.583547721d0,1.014141963d0,.5104134759d0,-.1790430468d0, &
      -1.756358428d0,.7561986717d0,-.6775248254d0,-.04014016420d0,.01446794851d0, &
      .1200521731d0,-.2203584559d0,4.508963850d0,.8221623576d0,1.779933730d0, &
      1.102649543d0,.8867880020d0/
      DATA A22/.4036015198d0,-.3302974212d0,2.827730930d0,-45.44405830d0, &
      -1.611103927d0,.4927112073d0,-.003258457559d0,-49.59014949d0,.3796217108d0, &
      -233.7884098d0,4.312666980d0,18.05051709d0,28.95320323d0,11.09948019d0, &
      .7471649558d0,67.10246193d0,.5667096597d0,.6468519751d0,-.1560665317d0, &
      -1.460805289d0,.7719653528d0,-.6658988668d0,.2515179349d-05, &
      .02426021891d0,.1195003324d0,-.2625739255d0,4.377172556d0,.2421190547d0, &
      2.503482679d0,1.071587299d0,.7247997430d0/

      B=0.5d0
      RHO_0=7.0d0

      M=MODE
      IF (NUMB.EQ.1) THEN
          DPHI=0.055D0
          DTHETA=0.06D0
      ENDIF

      IF (NUMB.EQ.2) THEN
          DPHI=0.030D0
          DTHETA=0.09D0
      ENDIF

      Xsc=X*XKAPPA
      Ysc=Y*XKAPPA
      Zsc=Z*XKAPPA
      RHO=DSQRT(Xsc**2+Zsc**2)

      Rsc=DSQRT(Xsc**2+Ysc**2+Zsc**2)                                 !  SCALED
      RHO2=RHO_0**2

      IF (Xsc.EQ.0.D0.AND.Zsc.EQ.0.D0) THEN
         PHI=0.D0
      ELSE
         PHI=DATAN2(-Zsc,Xsc)  !  FROM CARTESIAN TO CYLINDRICAL (RHO,PHI,Y)
      ENDIF

      SPHIC=DSIN(PHI)
      CPHIC=DCOS(PHI)  !  "C" means "CYLINDRICAL", TO DISTINGUISH FROM SPHERICAL PHI

      BRACK=DPHI+B*RHO2/(RHO2+1.D0)*(RHO**2-1.D0)/(RHO2+RHO**2)
      R1RH=(Rsc-1.D0)/RH
      IF (R1RH.LT.0.D0) R1RH=0.D0  !  AVOID NEGATIVE VALUES OF R1RH, WHICH MAY OCCUR IF THE
!                                     POINT (X,Y,Z) LIES CLOSE TO EARTH'S SURFACE AND THE S.W.
!                                     PRESSURE IS ABNORMALLY LOW

      PSIAS=BETA*PS/(1.D0+R1RH**EPS)**(1.D0/EPS)

      PHIS=PHI-BRACK*DSIN(PHI) -PSIAS
      DPHISPHI=1.D0-BRACK*DCOS(PHI)
      DPHISRHO=-2.D0*B*RHO2*RHO/(RHO2+RHO**2)**2 *DSIN(PHI) &
         +BETA*PS*R1RH**(EPS-1.D0)*RHO/(RH*Rsc* &
         (1.D0+R1RH**EPS)**(1.D0/EPS+1.D0))
      DPHISDY= BETA*PS*R1RH**(EPS-1.D0)*Ysc/(RH*Rsc* &
         (1.D0+R1RH**EPS)**(1.D0/EPS+1.D0))

      SPHICS=DSIN(PHIS)
      CPHICS=DCOS(PHIS)

      XS= RHO*CPHICS
      ZS=-RHO*SPHICS

      IF (NUMB.EQ.1) THEN
        IF (MODE.EQ.1) CALL TWOCONES (A11,XS,Ysc,ZS,BXS,BYAS,BZS)
        IF (MODE.EQ.2) CALL TWOCONES (A12,XS,Ysc,ZS,BXS,BYAS,BZS)
      ELSE
        IF (MODE.EQ.1) CALL TWOCONES (A21,XS,Ysc,ZS,BXS,BYAS,BZS)
        IF (MODE.EQ.2) CALL TWOCONES (A22,XS,Ysc,ZS,BXS,BYAS,BZS)
      ENDIF

      BRHOAS=BXS*CPHICS-BZS*SPHICS
      BPHIAS=-BXS*SPHICS-BZS*CPHICS

      BRHO_S=BRHOAS*DPHISPHI                             *XKAPPA        ! SCALING
      BPHI_S=(BPHIAS-RHO*(BYAS*DPHISDY+BRHOAS*DPHISRHO)) *XKAPPA
      BY_S=BYAS*DPHISPHI                                 *XKAPPA

      BX=BRHO_S*CPHIC-BPHI_S*SPHIC
      BY=BY_S
      BZ=-BRHO_S*SPHIC-BPHI_S*CPHIC

      RETURN
      END
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
      SUBROUTINE TWOCONES (A,X,Y,Z,BX,BY,BZ)
!
!  ADDS FIELDS FROM TWO CONES (NORTHERN AND SOUTHERN), WITH A PROPER SYMMETRY
!  OF THE CURRENT AND FIELD, CORRESPONDING TO THE REGION 1 BIRKELAND CURRENTS. (NB #6, P.58).
!
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION A(31)
      save

      CALL ONE_CONE (A,X,Y,Z,BXN,BYN,BZN)
      CALL ONE_CONE (A,X,-Y,-Z,BXS,BYS,BZS)
      BX=BXN-BXS
      BY=BYN+BYS
      BZ=BZN+BZS

      RETURN
      END
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
      SUBROUTINE ONE_CONE(A,X,Y,Z,BX,BY,BZ)
!
!  RETURNS FIELD COMPONENTS FOR A DEFORMED CONICAL CURRENT SYSTEM, FITTED TO A BIOSAVART FIELD
!  HERE ONLY THE NORTHERN CONE IS TAKEN INTO ACCOUNT.
!
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION A(31)
      save

      COMMON /DTHETA/ DTHETA
      COMMON /MODENUM/ M

      DATA DR,DT/1.D-6,1.D-6/  !   JUST FOR NUMERICAL DIFFERENTIATION

      THETA0=A(31)

      RHO2=X**2+Y**2
      RHO=DSQRT(RHO2)
      R=DSQRT(RHO2+Z**2)
      THETA=DATAN2(RHO,Z)
      PHI=DATAN2(Y,X)
!
!   MAKE THE DEFORMATION OF COORDINATES:
!
       RS=R_S(A,R,THETA)
       THETAS=THETA_S(A,R,THETA)
       PHIS=PHI
!
!   CALCULATE FIELD COMPONENTS AT THE NEW POSITION (ASTERISKED):
!
       CALL FIALCOS (RS,THETAS,PHIS,BTAST,BFAST,M,THETA0,DTHETA)    !   MODE #M
!
!   NOW TRANSFORM B{R,T,F}_AST BY THE DEFORMATION TENSOR:
!
!      FIRST OF ALL, FIND THE DERIVATIVES:
!
       DRSDR=(R_S(A,R+DR,THETA)-R_S(A,R-DR,THETA))/(2.D0*DR)
       DRSDT=(R_S(A,R,THETA+DT)-R_S(A,R,THETA-DT))/(2.D0*DT)
       DTSDR=(THETA_S(A,R+DR,THETA)-THETA_S(A,R-DR,THETA))/(2.D0*DR)
       DTSDT=(THETA_S(A,R,THETA+DT)-THETA_S(A,R,THETA-DT))/(2.D0*DT)

       STSST=DSIN(THETAS)/DSIN(THETA)
       RSR=RS/R

       BR     =-RSR/R*STSST*BTAST*DRSDT                 !   NB#6, P.43    BRAST DOES NOT ENTER HERE
       BTHETA = RSR*STSST*BTAST*DRSDR                  !          (IT IS IDENTICALLY ZERO IN OUR CASE)
       BPHI   = RSR*BFAST*(DRSDR*DTSDT-DRSDT*DTSDR)

       S=RHO/R
       C=Z/R
       SF=Y/RHO
       CF=X/RHO

       BE=BR*S+BTHETA*C

       BX=A(1)*(BE*CF-BPHI*SF)
       BY=A(1)*(BE*SF+BPHI*CF)
       BZ=A(1)*(BR*C-BTHETA*S)

       RETURN
       END
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

      DOUBLE PRECISION FUNCTION R_S(A,R,THETA)
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION A(31)
      save
!
      R_S=R+A(2)/R+A(3)*R/DSQRT(R**2+A(11)**2)+A(4)*R/(R**2+A(12)**2) &
      +(A(5)+A(6)/R+A(7)*R/DSQRT(R**2+A(13)**2)+A(8)*R/(R**2+A(14)**2))* &
       DCOS(THETA) &
      +(A(9)*R/DSQRT(R**2+A(15)**2)+A(10)*R/(R**2+A(16)**2)**2) &
       *DCOS(2.D0*THETA)
!
      RETURN
      END
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
      DOUBLE PRECISION FUNCTION THETA_S(A,R,THETA)
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION A(31)
      save
!
      THETA_S=THETA+(A(17)+A(18)/R+A(19)/R**2 &
                      +A(20)*R/DSQRT(R**2+A(27)**2))*DSIN(THETA) &
       +(A(21)+A(22)*R/DSQRT(R**2+A(28)**2) &
                      +A(23)*R/(R**2+A(29)**2))*DSIN(2.D0*THETA) &
       +(A(24)+A(25)/R+A(26)*R/(R**2+A(30)**2))*DSIN(3.D0*THETA)
!
      RETURN
      END
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
      SUBROUTINE FIALCOS(R,THETA,PHI,BTHETA,BPHI,N,THETA0,DT)
!
!  CONICAL MODEL OF BIRKELAND CURRENT FIELD; BASED ON THE OLD S/R FIALCO (OF 1990-91)
!  NB OF 1985-86-88, NOTE OF MARCH 5, BUT HERE BOTH INPUT AND OUTPUT ARE IN SPHERICAL CDS.

!  BTN, AND BPN ARE THE ARRAYS OF BTHETA AND BPHI (BTN(i), BPN(i) CORRESPOND TO i-th MODE).
!   ONLY FIRST  N  MODE AMPLITUDES ARE COMPUTED (N<=10).
!    THETA0 IS THE ANGULAR HALF-WIDTH OF THE CONE, DT IS THE ANGULAR H.-W. OF THE CURRENT LAYER

!   NOTE:  BR=0  (BECAUSE ONLY RADIAL CURRENTS ARE PRESENT IN THIS MODEL)
!
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION  BTN(10),BPN(10),CCOS(10),SSIN(10)
      save

      SINTE=DSIN(THETA)
      RO=R*SINTE
      COSTE=DCOS(THETA)
      SINFI=DSIN(PHI)
      COSFI=DCOS(PHI)
      TG=SINTE/(1.D0+COSTE)   !        TAN(THETA/2)
      CTG=SINTE/(1.D0-COSTE)  !        COT(THETA/2)
!
!
      TETANP=THETA0+DT
      TETANM=THETA0-DT
      IF(THETA.LT.TETANM) GOTO 1
      TGP=DTAN(TETANP*0.5D0)
      TGM=DTAN(TETANM*0.5D0)
      TGM2=TGM*TGM
      TGP2=TGP*TGP
  1   CONTINUE

      COSM1=1.D0
      SINM1=0.D0
      TM=1.D0
      TGM2M=1.D0
      TGP2M=1.D0

      DO 2 M=1,N
      TM=TM*TG
      CCOS(M)=COSM1*COSFI-SINM1*SINFI
      SSIN(M)=SINM1*COSFI+COSM1*SINFI
      COSM1=CCOS(M)
      SINM1=SSIN(M)
      IF(THETA.LT.TETANM) THEN
      T=TM
      DTT=0.5D0*dble(M)*TM*(TG+CTG)
! jah, foresys : Result of assignment to DTT0 is not used
! jah,      DTT0=0.D0
      ELSE IF(THETA.LT.TETANP) THEN
      TGM2M=TGM2M*TGM2
      FC=1.D0/(TGP-TGM)
      FC1=1.D0/dble(2*M+1)
      TGM2M1=TGM2M*TGM
      TG21=1.D0+TG*TG
      T=FC*(TM*(TGP-TG)+FC1*(TM*TG-TGM2M1/TM))
      DTT=0.5D0*dble(M)*FC*TG21*(TM/TG*(TGP-TG)-FC1*(TM-TGM2M1/(TM*TG)))
! jah, foresys : Result of assignment to DTT0 is not used
! jah,      DTT0=0.5D0*FC*((TGP+TGM)*(TM*TG-FC1*(TM*TG-TGM2M1/TM))+
! jah,     * TM*(1.D0-TGP*TGM)-(1.D0+TGM2)*TGM2M/TM)
      ELSE
      TGP2M=TGP2M*TGP2
      TGM2M=TGM2M*TGM2
      FC=1.D0/(TGP-TGM)
      FC1=1.D0/dble(2*M+1)
      T=FC*FC1*(TGP2M*TGP-TGM2M*TGM)/TM
      DTT=-T*dble(M)*0.5D0*(TG+CTG)
      ENDIF

      BTN(M)=dble(M)*T*CCOS(M)/RO
  2   BPN(M)=-DTT*SSIN(M)/R

      BTHETA=BTN(N)*800.d0
      BPHI  =BPN(N)*800.d0

      RETURN
      END
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
         SUBROUTINE BIRK_SHL (A,PS,X_SC,X,Y,Z,BX,BY,BZ)
!
       IMPLICIT  REAL * 8  (A - H, O - Z)
         DIMENSION A(86)
      save
!
         CPS=DCOS(PS)
         SPS=DSIN(PS)

         S3PS=2.D0*CPS
!
         PST1=PS*A(85)
         PST2=PS*A(86)

         ST1=DSIN(PST1)
         CT1=DCOS(PST1)
         ST2=DSIN(PST2)
         CT2=DCOS(PST2)

         X1=X*CT1-Z*ST1
         Z1=X*ST1+Z*CT1
         X2=X*CT2-Z*ST2
         Z2=X*ST2+Z*CT2
!
         L=0
         GX=0.D0
         GY=0.D0
         GZ=0.D0
!
         DO 1 M=1,2     !    M=1 IS FOR THE 1ST SUM ("PERP." SYMMETRY)
!                          AND M=2 IS FOR THE SECOND SUM ("PARALL." SYMMETRY)
             DO 2 I=1,3
                  P=A(72+I)
                  Q=A(78+I)
                  CYPI=DCOS(Y/P)
                  CYQI=DCOS(Y/Q)
                  SYPI=DSIN(Y/P)
                  SYQI=DSIN(Y/Q)
!
                DO 3 K=1,3
                   R=A(75+K)
                   S=A(81+K)
                   SZRK=DSIN(Z1/R)
                   CZSK=DCOS(Z2/S)
                   CZRK=DCOS(Z1/R)
                   SZSK=DSIN(Z2/S)
                     SQPR=DSQRT(1.D0/P**2+1.D0/R**2)
                     SQQS=DSQRT(1.D0/Q**2+1.D0/S**2)
                        EPR=DEXP(X1*SQPR)
                        EQS=DEXP(X2*SQQS)
!
                  DO 4 N=1,2  ! N=1 IS FOR THE FIRST PART OF EACH COEFFICIENT
!                                AND N=2 IS FOR THE SECOND ONE

                    DO 5 NN=1,2 !   NN = 1,2 FURTHER SPLITS THE COEFFICIENTS INTO 2 PARTS,
!                                         TO TAKE INTO ACCOUNT THE SCALE FACTOR DEPENDENCE

                    IF (M.EQ.1) THEN
                         FX=-SQPR*EPR*CYPI*SZRK
                         FY=EPR*SYPI*SZRK/P
                         FZ=-EPR*CYPI*CZRK/R
                       IF (N.EQ.1) THEN
                         IF (NN.EQ.1) THEN
                          HX=FX
                          HY=FY
                          HZ=FZ
                         ELSE
                          HX=FX*X_SC
                          HY=FY*X_SC
                          HZ=FZ*X_SC
                         ENDIF
                       ELSE
                         IF (NN.EQ.1) THEN
                          HX=FX*CPS
                          HY=FY*CPS
                          HZ=FZ*CPS
                         ELSE
                          HX=FX*CPS*X_SC
                          HY=FY*CPS*X_SC
                          HZ=FZ*CPS*X_SC
                         ENDIF
                       ENDIF

                     ELSE                            !   M.EQ.2
                         FX=-SPS*SQQS*EQS*CYQI*CZSK
                         FY=SPS/Q*EQS*SYQI*CZSK
                         FZ=SPS/S*EQS*CYQI*SZSK
                       IF (N.EQ.1) THEN
                        IF (NN.EQ.1) THEN
                          HX=FX
                          HY=FY
                          HZ=FZ
                        ELSE
                          HX=FX*X_SC
                          HY=FY*X_SC
                          HZ=FZ*X_SC
                        ENDIF
                       ELSE
                        IF (NN.EQ.1) THEN
                         HX=FX*S3PS
                         HY=FY*S3PS
                         HZ=FZ*S3PS
                        ELSE
                         HX=FX*S3PS*X_SC
                         HY=FY*S3PS*X_SC
                         HZ=FZ*S3PS*X_SC
                        ENDIF
                       ENDIF
                  ENDIF
       L=L+1

       IF (M.EQ.1) THEN
       HXR=HX*CT1+HZ*ST1
       HZR=-HX*ST1+HZ*CT1
       ELSE
       HXR=HX*CT2+HZ*ST2
       HZR=-HX*ST2+HZ*CT2
       ENDIF

       GX=GX+HXR*A(L)
       GY=GY+HY *A(L)
  5    GZ=GZ+HZR*A(L)

  4   CONTINUE
  3   CONTINUE
  2   CONTINUE
  1   CONTINUE

      BX=GX
      BY=GY
      BZ=GZ

      RETURN
      END

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
      SUBROUTINE FULL_RC (IOPR,PS,X,Y,Z,BXSRC,BYSRC,BZSRC,BXPRC,BYPRC, &
        BZPRC)
!
!   CALCULATES GSM FIELD COMPONENTS OF THE SYMMETRIC (SRC) AND PARTIAL (PRC) COMPONENTS OF THE RING CURRENT
!   SRC  PROVIDES A DEPRESSION OF -28 nT AT EARTH
!   PRC  CORRESPONDS TO THE PRESSURE DIFFERENCE OF 2 nPa BETWEEN MIDNIGHT AND NOON RING CURRENT
!             PARTICLE PRESSURE AND YIELDS A DEPRESSION OF -17 nT AT X=-6Re
!
!   SC_SY AND SC_PR ARE SCALING FACTORS FOR THE SYMMETRIC AND PARTIAL COMPONENTS:
!          VALUES LARGER THAN 1 RESULT IN SPATIALLY LARGER CURRENTS
!
!   PHI IS THE ROTATION ANGLE IN RADIANS OF THE PARTIAL RING CURRENT (MEASURED FROM MIDNIGHT TOWARD DUSK)
!
!     IOPR -  A RING CURRENT CALCULATION FLAG (FOR LEAST-SQUARES FITTING ONLY):
!             IOPR=0 - BOTH SRC AND PRC FIELDS ARE CALCULATED
!             IOPR=1 - SRC ONLY
!             IOPR=2 - PRC ONLY
!
        IMPLICIT REAL*8 (A-H,O-Z)
        DIMENSION C_SY(86),C_PR(86)
      save
        COMMON /RCPAR/ SC_SY,SC_PR,PHI
!
        DATA C_SY/1675.694858d0,1780.006388d0,-961.6082149d0,-1668.914259d0, &
      -27.40437029d0,-107.4169670d0,27.76189943d0,92.89740503d0,-43.92949274d0, &
      -403.6444072d0,6.167161865d0,298.2779761d0,-1680.779044d0,-1780.933039d0, &
      964.1861088d0,1670.988659d0,27.48864650d0,107.7809519d0,-27.84600972d0, &
      -93.20691865d0,44.28496784d0,404.4537249d0,-6.281958730d0,-298.6050952d0, &
      -7.971914848d0,2.017383761d0,-1.492230168d0,-1.957411655d0,-.08525523181d0, &
      -.3811813235d0,.08446716725d0,.3215044399d0,-.7141912767d0,-.9086294596d0, &
      .2966677742d0,-.04736679933d0,-11.38731325d0,.1719795189d0,1.356233066d0, &
      .8613438429d0,-.09143823092d0,-.2593979098d0,.04244838338d0,.06318383319d0, &
      -.5861372726d0,-.03368780733d0,-.07104470269d0,-.06909052953d0, &
      -60.18659631d0,-32.87563877d0,11.76450433d0,5.891673644d0,2.562360333d0, &
      6.215377232d0,-1.273945165d0,-1.864704763d0,-5.394837143d0,-8.799382627d0, &
      3.743066561d0,-.7649164511d0,57.09210569d0,32.61236511d0,-11.28688017d0, &
      -5.849523392d0,-2.470635922d0,-5.961417272d0,1.230031099d0,1.793192595d0, &
      5.383736074d0,8.369895153d0,-3.611544412d0,.7898988697d0,7.970609948d0, &
      7.981216562d0,35.16822497d0,12.45651654d0,1.689755359d0,3.678712366d0, &
      23.66117284d0,6.987136092d0,6.886678677d0,20.91245928d0,1.650064156d0, &
      3.474068566d0,.3474715765d0,.6564043111d0/

        DATA C_PR/-64820.58481d0,-63965.62048d0,66267.93413d0,135049.7504d0, &
      -36.56316878d0,124.6614669d0,56.75637955d0,-87.56841077d0,5848.631425d0, &
      4981.097722d0,-6233.712207d0,-10986.40188d0,68716.52057d0,65682.69473d0, &
      -69673.32198d0,-138829.3568d0,43.45817708d0,-117.9565488d0,-62.14836263d0, &
      79.83651604d0,-6211.451069d0,-5151.633113d0,6544.481271d0,11353.03491d0, &
      23.72352603d0,-256.4846331d0,25.77629189d0,145.2377187d0,-4.472639098d0, &
      -3.554312754d0,2.936973114d0,2.682302576d0,2.728979958d0,26.43396781d0, &
      -9.312348296d0,-29.65427726d0,-247.5855336d0,-206.9111326d0,74.25277664d0, &
      106.4069993d0,15.45391072d0,16.35943569d0,-5.965177750d0,-6.079451700d0, &
      115.6748385d0,-35.27377307d0,-32.28763497d0,-32.53122151d0,93.74409310d0, &
      84.25677504d0,-29.23010465d0,-43.79485175d0,-6.434679514d0,-6.620247951d0, &
      2.443524317d0,2.266538956d0,-43.82903825d0,6.904117876d0,12.24289401d0, &
      17.62014361d0,152.3078796d0,124.5505289d0,-44.58690290d0,-63.02382410d0, &
      -8.999368955d0,-9.693774119d0,3.510930306d0,3.770949738d0,-77.96705716d0, &
      22.07730961d0,20.46491655d0,18.67728847d0,9.451290614d0,9.313661792d0, &
      644.7620970d0,418.2515954d0,7.183754387d0,35.62128817d0,19.43180682d0, &
      39.57218411d0,15.69384715d0,7.123215241d0,2.300635346d0,21.90881131d0, &
      -.01775839370d0,.3996346710d0/

        CALL SRC_PRC (IOPR,SC_SY,SC_PR,PHI,PS,X,Y,Z,HXSRC,HYSRC,HZSRC, &
            HXPRC,HYPRC,HZPRC)

        X_SC=SC_SY-1.D0
        IF (IOPR.EQ.0.OR.IOPR.EQ.1) THEN
          CALL RC_SHIELD (C_SY,PS,X_SC,X,Y,Z,FSX,FSY,FSZ)
        ELSE
           FSX=0.D0
           FSY=0.D0
           FSZ=0.D0
        ENDIF

        X_SC=SC_PR-1.D0
        IF (IOPR.EQ.0.OR.IOPR.EQ.2) THEN
          CALL RC_SHIELD (C_PR,PS,X_SC,X,Y,Z,FPX,FPY,FPZ)
        ELSE
           FPX=0.D0
           FPY=0.D0
           FPZ=0.D0
        ENDIF

        BXSRC=HXSRC+FSX
        BYSRC=HYSRC+FSY
        BZSRC=HZSRC+FSZ

        BXPRC=HXPRC+FPX
        BYPRC=HYPRC+FPY
        BZPRC=HZPRC+FPZ

        RETURN
        END
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

       SUBROUTINE SRC_PRC (IOPR,SC_SY,SC_PR,PHI,PS,X,Y,Z,BXSRC,BYSRC, &
          BZSRC,BXPRC,BYPRC,BZPRC)
!
!   RETURNS FIELD COMPONENTS FROM A MODEL RING CURRENT, INCLUDING ITS SYMMETRIC PART
!     AND A PARTIAL RING CURRENT, CLOSED VIA BIRKELAND CURRENTS. BASED ON RESULTS, DESCRIBED
!     IN A PAPER "MODELING THE INNER MAGNETOSPHERE: ASYMMETRIC RING CURRENT AND REGION 2
!     BIRKELAND CURRENTS REVISITED" (JGR, DEC.2000).
!
!     IOPR -  A RING CURRENT CALCULATION FLAG (FOR LEAST-SQUARES FITTING ONLY):
!             IOPR=0 - BOTH SRC AND PRC FIELDS ARE CALCULATED
!             IOPR=1 - SRC ONLY
!             IOPR=2 - PRC ONLY
!
!     SC_SY &  SC_PR ARE SCALE FACTORS FOR THE ABOVE COMPONENTS;  TAKING SC<1 OR SC>1 MAKES THE CURRENTS
!                      SHRINK OR EXPAND, RESPECTIVELY.
!
!   PHI IS THE ROTATION ANGLE (RADIANS) OF THE PARTIAL RING CURRENT (MEASURED FROM MIDNIGHT TOWARD DUSK)
!
        IMPLICIT REAL*8 (A-H,O-Z)
      save
!
!   1.  TRANSFORM TO TILTED COORDINATES (i.e., SM coordinates):
!
        CPS=DCOS(PS)
        SPS=DSIN(PS)

        XT=X*CPS-Z*SPS
        ZT=Z*CPS+X*SPS
!
!   2.  SCALE THE COORDINATES FOR THE SYMMETRIC AND PARTIAL RC COMPONENTS:
!
        XTS=XT/SC_SY    !  SYMMETRIC
        YTS=Y /SC_SY
        ZTS=ZT/SC_SY

        XTA=XT/SC_PR    !  PARTIAL
        YTA=Y /SC_PR
        ZTA=ZT/SC_PR
!
!   3.  CALCULATE COMPONENTS OF THE TOTAL FIELD IN THE TILTED (SOLAR-MAGNETIC) COORDINATE SYSTEM:
!
!==========   ONLY FOR LEAST SQUARES FITTING:
        BXS=0.D0
        BYS=0.D0
        BZS=0.D0
        BXA_S=0.D0
        BYA_S=0.D0
        BZA_S=0.D0
        BXA_QR=0.D0
        BYA_QR=0.D0
        BZA_Q=0.D0
!============================================
!
!    3a. SYMMETRIC FIELD:
!
        IF (IOPR.LE.1) CALL RC_SYMM(XTS,YTS,ZTS,BXS,BYS,BZS)
        IF (IOPR.EQ.0.OR.IOPR.EQ.2) &
                       CALL PRC_SYMM(XTA,YTA,ZTA,BXA_S,BYA_S,BZA_S)

!    3b. ROTATE THE SCALED SM COORDINATES BY PHI AROUND ZSM AXIS AND CALCULATE QUADRUPOLE PRC FIELD
!         IN THOSE COORDS:

        CP=DCOS(PHI)
        SP=DSIN(PHI)
        XR=XTA*CP-YTA*SP
        YR=XTA*SP+YTA*CP

        IF (IOPR.EQ.0.OR.IOPR.EQ.2) &
                       CALL PRC_QUAD(XR,YR,ZTA,BXA_QR,BYA_QR,BZA_Q)

!    3c. TRANSFORM THE QUADRUPOLE FIELD COMPONENTS BACK TO THE SM COORDS:
!
        BXA_Q= BXA_QR*CP+BYA_QR*SP
        BYA_Q=-BXA_QR*SP+BYA_QR*CP

!    3d. FIND THE TOTAL FIELD OF PRC (SYMM.+QUADR.) IN THE SM COORDS:
!
        BXP=BXA_S+BXA_Q
        BYP=BYA_S+BYA_Q
        BZP=BZA_S+BZA_Q
!
!   4.  TRANSFORM THE FIELDS OF BOTH PARTS OF THE RING CURRENT BACK TO THE GSM SYSTEM:
!
        BXSRC=BXS*CPS+BZS*SPS   !    SYMMETRIC RC
        BYSRC=BYS
        BZSRC=BZS*CPS-BXS*SPS
!
        BXPRC=BXP*CPS+BZP*SPS   !    PARTIAL RC
        BYPRC=BYP
        BZPRC=BZP*CPS-BXP*SPS
!
        RETURN
        END
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
      SUBROUTINE RC_SYMM (X,Y,Z,BX,BY,BZ)
      IMPLICIT  REAL * 8  (A - H, O - Z)
      save
      DATA DS,DC/1.D-2,0.99994999875D0/, D/1.D-4/,DRD/5.D3/  ! DS=SIN(THETA) AT THE BOUNDARY OF THE LINEARITY
!                                                                        REGION; DC=SQRT(1-DS**2);  DRD=1/(2*D)
      RHO2=X**2+Y**2
      R2=RHO2+Z**2
      R=DSQRT(R2)
      RP=R+D
      RM=R-D
      SINT=DSQRT(RHO2)/R
      COST=Z/R

      IF (SINT.LT.DS) THEN  !  TOO CLOSE TO THE Z-AXIS; USING A LINEAR APPROXIMATION A_PHI~SINT,
!                                    TO AVOID THE SINGULARITY PROBLEM
        A=AP(R,DS,DC)/DS
        DARDR=(RP*AP(RP,DS,DC)-RM*AP(RM,DS,DC))*DRD
        FXY=Z*(2.D0*A-DARDR)/(R*R2)
        BX=FXY*X
        BY=FXY*Y
        BZ=(2.D0*A*COST**2+DARDR*SINT**2)/R

       ELSE

        THETA=DATAN2(SINT,COST)
        TP=THETA+D
        TM=THETA-D
        SINTP=DSIN(TP)
        SINTM=DSIN(TM)
        COSTP=DCOS(TP)
        COSTM=DCOS(TM)
        BR=(SINTP*AP(R,SINTP,COSTP)-SINTM*AP(R,SINTM,COSTM)) &
             /(R*SINT)*DRD
        BT=(RM*AP(RM,SINT,COST)-RP*AP(RP,SINT,COST))/R*DRD
        FXY=(BR+BT*COST/SINT)/R
        BX=FXY*X
        BY=FXY*Y
        BZ=BR*COST-BT*SINT

      ENDIF

      RETURN
      END
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

      DOUBLE PRECISION FUNCTION AP(R,SINT,COST)
!
!      Calculates azimuthal component of the vector potential of the symmetric
!  part of the model ring current.
!
      IMPLICIT  REAL * 8  (A - H, O - Z)
      save
!  INDICATES WHETHER WE ARE TOO CLOSE TO THE AXIS OF SYMMETRY, WHERE THE INVERSION
      LOGICAL PROX   
!                                                             OF DIPOLAR COORDINATES BECOMES INACCURATE
      DATA A1,A2,RRC1,DD1,RRC2,DD2,P1,R1,DR1,DLA1,P2,R2,DR2,DLA2,P3, &
      R3,DR3/ &
      -563.3722359d0,425.0891691d0,4.150588549d0,2.266150226d0, &
       3.334503403d0,3.079071195d0,.02602428295d0,8.937790598d0,3.327934895d0, &
      .4487061833d0,.09125832351d0,6.243029867d0,1.750145910d0,.4181957162d0, &
      .06106691992d0,2.079908581d0,.6828548533d0/

      PROX=.FALSE.
      SINT1=SINT
      COST1=COST
      IF (SINT1.LT.1.D-2) THEN  !  TOO CLOSE TO Z-AXIS;  USE LINEAR INTERPOLATION BETWEEN SINT=0 & SINT=0.01
        SINT1=1.D-2
        COST1=.99994999875d0
        PROX=.TRUE.
      ENDIF

         ALPHA=SINT1**2/R         !  R,THETA -> ALPHA,GAMMA
         GAMMA=COST1/R**2

         ARG1=-((R-R1)/DR1)**2-(COST1/DLA1)**2
         ARG2=-((R-R2)/DR2)**2-(COST1/DLA2)**2
         ARG3=-((R-R3)/DR3)**2

         IF (ARG1.LT.-500.D0) THEN        !   TO PREVENT "FLOATING UNDERFLOW" CRASHES
           DEXP1=0.D0
         ELSE
           DEXP1=DEXP(ARG1)
         ENDIF

         IF (ARG2.LT.-500.D0) THEN
           DEXP2=0.D0
         ELSE
           DEXP2=DEXP(ARG2)
         ENDIF

         IF (ARG3.LT.-500.D0) THEN
           DEXP3=0.D0
         ELSE
           DEXP3=DEXP(ARG3)
         ENDIF


         ALPHA_S=ALPHA*(1.D0+P1*DEXP1+P2*DEXP2+P3*DEXP3)     !  ALPHA -> ALPHA_S  (DEFORMED)

         GAMMA_S=GAMMA
         GAMMAS2=GAMMA_S**2


         ALSQH=ALPHA_S**2/2.D0            !  ALPHA_S,GAMMA_S -> RS,SINTS,COSTS
         F=64.D0/27.D0*GAMMAS2+ALSQH**2
         Q=(DSQRT(F)+ALSQH)**(1.D0/3.D0)
         C=Q-4.D0*GAMMAS2**(1.D0/3.D0)/(3.D0*Q)
         IF (C.LT.0.D0) C=0.D0
         G=DSQRT(C**2+4.D0*GAMMAS2**(1.D0/3.D0))
         RS=4.D0/((DSQRT(2.D0*G-C)+DSQRT(C))*(G+C))
         COSTS=GAMMA_S*RS**2
         SINTS=DSQRT(1.D0-COSTS**2)
         RHOS=RS*SINTS
! jah, foresys : Result of assignment to RHOS2 is not used
! jah, RHOS2=RHOS**2
!         RHOS2=RHOS**2
         ZS=RS*COSTS
!
!  1st loop:

         P=(RRC1+RHOS)**2+ZS**2+DD1**2
         XK2=4.D0*RRC1*RHOS/P
         XK=SQRT(XK2)
         XKRHO12=XK*SQRT(RHOS)     !   SEE NB#4, P.3
!
      XK2S=1.D0-XK2
      DL=DLOG(1.D0/XK2S)
      ELK=1.38629436112d0+XK2S*(0.09666344259D0+XK2S*(0.03590092383d0+ &
           XK2S*(0.03742563713d0+XK2S*0.01451196212d0))) +DL* &
           (0.5D0+XK2S*(0.12498593597D0+XK2S*(0.06880248576D0+ &
           XK2S*(0.03328355346D0+XK2S*0.00441787012D0))))
      ELE=1.D0+XK2S*(0.44325141463D0+XK2S*(0.0626060122D0+XK2S* &
            (0.04757383546D0+XK2S*0.01736506451D0))) +DL* &
           XK2S*(0.2499836831D0+XK2S*(0.09200180037D0+XK2S* &
             (0.04069697526D0+XK2S*0.00526449639D0)))
!
      APHI1=((1.D0-XK2*0.5D0)*ELK-ELE)/XKRHO12
!
!  2nd loop:

         P=(RRC2+RHOS)**2+ZS**2+DD2**2
         XK2=4.D0*RRC2*RHOS/P
         XK=SQRT(XK2)
         XKRHO12=XK*SQRT(RHOS)     !   SEE NB#4, P.3
!
      XK2S=1.D0-XK2
      DL=DLOG(1.D0/XK2S)
      ELK=1.38629436112d0+XK2S*(0.09666344259D0+XK2S*(0.03590092383d0+ &
           XK2S*(0.03742563713d0+XK2S*0.01451196212d0))) +DL* &
           (0.5D0+XK2S*(0.12498593597D0+XK2S*(0.06880248576D0+ &
           XK2S*(0.03328355346D0+XK2S*0.00441787012D0))))
      ELE=1.D0+XK2S*(0.44325141463D0+XK2S*(0.0626060122D0+XK2S* &
            (0.04757383546D0+XK2S*0.01736506451D0))) +DL* &
           XK2S*(0.2499836831D0+XK2S*(0.09200180037D0+XK2S* &
             (0.04069697526D0+XK2S*0.00526449639D0)))
!
       APHI2=((1.D0-XK2*0.5D0)*ELK-ELE)/XKRHO12

       AP=A1*APHI1+A2*APHI2
       IF (PROX) AP=AP*SINT/SINT1   !   LINEAR INTERPOLATION, IF TOO CLOSE TO THE Z-AXIS
!
       RETURN
       END
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
      SUBROUTINE PRC_SYMM (X,Y,Z,BX,BY,BZ)
      IMPLICIT  REAL * 8  (A - H, O - Z)
      save
      DATA DS,DC/1.D-2,0.99994999875D0/, D/1.D-4/,DRD/5.D3/  ! DS=SIN(THETA) AT THE BOUNDARY OF THE LINEARITY
!                                                                        REGION; DC=SQRT(1-DS**2);  DRD=1/(2*D)
      RHO2=X**2+Y**2
      R2=RHO2+Z**2
      R=DSQRT(R2)
      RP=R+D
      RM=R-D
      SINT=DSQRT(RHO2)/R
      COST=Z/R

      IF (SINT.LT.DS) THEN  !  TOO CLOSE TO THE Z-AXIS; USING A LINEAR APPROXIMATION A_PHI~SINT,
!                                    TO AVOID THE SINGULARITY PROBLEM
        A=APPRC(R,DS,DC)/DS
        DARDR=(RP*APPRC(RP,DS,DC)-RM*APPRC(RM,DS,DC))*DRD
        FXY=Z*(2.D0*A-DARDR)/(R*R2)
        BX=FXY*X
        BY=FXY*Y
        BZ=(2.D0*A*COST**2+DARDR*SINT**2)/R

       ELSE

        THETA=DATAN2(SINT,COST)
        TP=THETA+D
        TM=THETA-D
        SINTP=DSIN(TP)
        SINTM=DSIN(TM)
        COSTP=DCOS(TP)
        COSTM=DCOS(TM)
        BR=(SINTP*APPRC(R,SINTP,COSTP)-SINTM*APPRC(R,SINTM,COSTM)) &
             /(R*SINT)*DRD
        BT=(RM*APPRC(RM,SINT,COST)-RP*APPRC(RP,SINT,COST))/R*DRD
        FXY=(BR+BT*COST/SINT)/R
        BX=FXY*X
        BY=FXY*Y
        BZ=BR*COST-BT*SINT

      ENDIF

      RETURN
      END
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
      DOUBLE PRECISION FUNCTION APPRC(R,SINT,COST)
!
!      Calculates azimuthal component of the vector potential of the symmetric
!  part of the model PARTIAL ring current.
!
      IMPLICIT  REAL * 8  (A - H, O - Z)
      save
      LOGICAL PROX
      DATA A1,A2,RRC1,DD1,RRC2,DD2,P1,ALPHA1,DAL1,BETA1,DG1,P2,ALPHA2, &
       DAL2,BETA2,DG2,BETA3,P3,ALPHA3,DAL3,BETA4,DG3,BETA5,Q0,Q1,ALPHA4, &
       DAL4,DG4,Q2,ALPHA5,DAL5,DG5,BETA6,BETA7 &
       /-80.11202281d0,12.58246758d0,6.560486035d0,1.930711037d0,3.827208119d0, &
      .7789990504d0,.3058309043d0,.1817139853d0,.1257532909d0,3.422509402d0, &
      .04742939676d0,-4.800458958d0,-.02845643596d0,.2188114228d0,2.545944574d0, &
      .00813272793d0,.35868244d0,103.1601001d0,-.00764731187d0,.1046487459d0, &
      2.958863546d0,.01172314188d0,.4382872938d0,.01134908150d0,14.51339943d0, &
      .2647095287d0,.07091230197d0,.01512963586d0,6.861329631d0,.1677400816d0, &
      .04433648846d0,.05553741389d0,.7665599464d0,.7277854652d0/

      PROX=.FALSE.
      SINT1=SINT
      COST1=COST
      IF (SINT1.LT.1.D-2) THEN  !  TOO CLOSE TO Z-AXIS;  USE LINEAR INTERPOLATION BETWEEN SINT=0 & SINT=0.01
        SINT1=1.D-2
        COST1=.99994999875d0
        PROX=.TRUE.
      ENDIF

         ALPHA=SINT1**2/R         !  R,THETA -> ALPHA,GAMMA
         GAMMA=COST1/R**2

         ALPHA_S=ALPHA*(1.D0+P1/(1.D0+((ALPHA-ALPHA1)/DAL1)**2)**BETA1 &
       *DEXP(-(GAMMA/DG1)**2) &
      +P2*(ALPHA-ALPHA2)/(1.D0+((ALPHA-ALPHA2)/DAL2)**2)**BETA2 &
      /(1.D0+(GAMMA/DG2)**2)**BETA3 &
      +P3*(ALPHA-ALPHA3)**2/(1.D0+((ALPHA-ALPHA3)/DAL3)**2)**BETA4 &
      /(1.D0+(GAMMA/DG3)**2)**BETA5)     !  ALPHA -> ALPHA_S  (DEFORMED)

         GAMMA_S=GAMMA*(1.D0+Q0+Q1*(ALPHA-ALPHA4) &
       *DEXP(-((ALPHA-ALPHA4)/DAL4)**2-(GAMMA/DG4)**2)    &!  GAMMA -> GAMMA_  (DEFORMED)
       +Q2*(ALPHA-ALPHA5)/(1.D0+((ALPHA-ALPHA5)/DAL5)**2)**BETA6 &
       /(1.D0+(GAMMA/DG5)**2)**BETA7)

         GAMMAS2=GAMMA_S**2

         ALSQH=ALPHA_S**2/2.D0                            !  ALPHA_S,GAMMA_S -> RS,SINTS,COSTS
         F=64.D0/27.D0*GAMMAS2+ALSQH**2
         Q=(DSQRT(F)+ALSQH)**(1.D0/3.D0)
         C=Q-4.D0*GAMMAS2**(1.D0/3.D0)/(3.D0*Q)
         IF (C.LT.0.D0) C=0.D0
         G=DSQRT(C**2+4.D0*GAMMAS2**(1.D0/3.D0))
         RS=4.D0/((DSQRT(2.D0*G-C)+DSQRT(C))*(G+C))
         COSTS=GAMMA_S*RS**2
         SINTS=DSQRT(1.D0-COSTS**2)
         RHOS=RS*SINTS
! jah, foresys : Result of assignment to RHOS2 is not used
! jah, RHOS2=RHOS**2
!         RHOS2=RHOS**2
         ZS=RS*COSTS
!
!  1st loop:

         P=(RRC1+RHOS)**2+ZS**2+DD1**2
         XK2=4.D0*RRC1*RHOS/P
         XK=SQRT(XK2)
         XKRHO12=XK*SQRT(RHOS)     !    NB#4, P.3
!
      XK2S=1.D0-XK2
      DL=DLOG(1.D0/XK2S)
      ELK=1.38629436112d0+XK2S*(0.09666344259D0+XK2S*(0.03590092383d0+ &
           XK2S*(0.03742563713d0+XK2S*0.01451196212d0))) +DL* &
           (0.5D0+XK2S*(0.12498593597D0+XK2S*(0.06880248576D0+ &
           XK2S*(0.03328355346D0+XK2S*0.00441787012D0))))
      ELE=1.D0+XK2S*(0.44325141463D0+XK2S*(0.0626060122D0+XK2S* &
            (0.04757383546D0+XK2S*0.01736506451D0))) +DL* &
           XK2S*(0.2499836831D0+XK2S*(0.09200180037D0+XK2S* &
             (0.04069697526D0+XK2S*0.00526449639D0)))
!
      APHI1=((1.D0-XK2*0.5D0)*ELK-ELE)/XKRHO12
!
!  2nd loop:

         P=(RRC2+RHOS)**2+ZS**2+DD2**2
         XK2=4.D0*RRC2*RHOS/P
         XK=SQRT(XK2)
         XKRHO12=XK*SQRT(RHOS)     !    NB#4, P.3
!
      XK2S=1.D0-XK2
      DL=DLOG(1.D0/XK2S)
      ELK=1.38629436112d0+XK2S*(0.09666344259D0+XK2S*(0.03590092383d0+ &
           XK2S*(0.03742563713d0+XK2S*0.01451196212d0))) +DL* &
           (0.5D0+XK2S*(0.12498593597D0+XK2S*(0.06880248576D0+ &
           XK2S*(0.03328355346D0+XK2S*0.00441787012D0))))
      ELE=1.D0+XK2S*(0.44325141463D0+XK2S*(0.0626060122D0+XK2S* &
            (0.04757383546D0+XK2S*0.01736506451D0))) +DL* &
           XK2S*(0.2499836831D0+XK2S*(0.09200180037D0+XK2S* &
             (0.04069697526D0+XK2S*0.00526449639D0)))
!
      APHI2=((1.D0-XK2*0.5D0)*ELK-ELE)/XKRHO12

      APPRC=A1*APHI1+A2*APHI2
      IF (PROX) APPRC=APPRC*SINT/SINT1   !   LINEAR INTERPOLATION, IF TOO CLOSE TO THE Z-AXIS
!
      RETURN
      END
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
         SUBROUTINE PRC_QUAD (X,Y,Z,BX,BY,BZ)
!
!  CALCULATES COMPONENTS OF THE FIELD FROM THE "QUADRUPOLE" COMPONENT OF THE PRC
!
         IMPLICIT  REAL * 8  (A - H, O - Z)
      save

         DATA D,DD/1.D-4,2.D-4/, DS/1.D-2/,DC/0.99994999875D0/

         RHO2=X**2+Y**2
         R=DSQRT(RHO2+Z**2)
         RHO=DSQRT(RHO2)
         SINT=RHO/R
         COST=Z/R
         RP=R+D
         RM=R-D

         IF (SINT.GT.DS) THEN
           CPHI=X/RHO
           SPHI=Y/RHO
           BR=BR_PRC_Q(R,SINT,COST)
           BT=BT_PRC_Q(R,SINT,COST)
           DBRR=(BR_PRC_Q(RP,SINT,COST)-BR_PRC_Q(RM,SINT,COST))/DD
           THETA=DATAN2(SINT,COST)
           TP=THETA+D
           TM=THETA-D
           SINTP=DSIN(TP)
           COSTP=DCOS(TP)
           SINTM=DSIN(TM)
           COSTM=DCOS(TM)
           DBTT=(BT_PRC_Q(R,SINTP,COSTP)-BT_PRC_Q(R,SINTM,COSTM))/DD
           BX=SINT*(BR+(BR+R*DBRR+DBTT)*SPHI**2)+COST*BT
           BY=-SINT*SPHI*CPHI*(BR+R*DBRR+DBTT)
           BZ=(BR*COST-BT*SINT)*CPHI
         ELSE
           ST=DS
           CT=DC
           IF (Z.LT.0.D0) CT=-DC
           THETA=DATAN2(ST,CT)
           TP=THETA+D
           TM=THETA-D
           SINTP=DSIN(TP)
           COSTP=DCOS(TP)
           SINTM=DSIN(TM)
           COSTM=DCOS(TM)
           BR=BR_PRC_Q(R,ST,CT)
           BT=BT_PRC_Q(R,ST,CT)
           DBRR=(BR_PRC_Q(RP,ST,CT)-BR_PRC_Q(RM,ST,CT))/DD
           DBTT=(BT_PRC_Q(R,SINTP,COSTP)-BT_PRC_Q(R,SINTM,COSTM))/DD
           FCXY=R*DBRR+DBTT
           BX=(BR*(X**2+2.D0*Y**2)+FCXY*Y**2)/(R*ST)**2+BT*COST
           BY=-(BR+FCXY)*X*Y/(R*ST)**2
           BZ=(BR*COST/ST-BT)*X/R
         ENDIF

         RETURN
         END
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
      DOUBLE PRECISION FUNCTION BR_PRC_Q (R,SINT,COST)
!
!alculates the radial component of the "quadrupole" part of the model partial ring current.
!
      IMPLICIT  REAL * 8  (A - H, O - Z)
      save

! ALL LINEAR PARAMETERS HERE
! WERE MULTIPLIED BY 0.1,
! SO THAT THEY CORRESPOND TO P_0=1 nPa,
! RATHER THAN THE ORIGINAL VALUE OF 10 nPa
! ASSUMED IN THE BIOT-SAVART INTEGRAL

      DATA A1,A2,A3,A4,A5,A6,A7,A8,A9,A10,A11,A12,A13,A14,A15,A16,A17, &
      A18,XK1,AL1,DAL1,B1,BE1,XK2,AL2,DAL2,B2,BE2,XK3,XK4,AL3,DAL3,B3, &
      BE3,AL4,DAL4,DG1,AL5,DAL5,DG2,C1,C2,C3,AL6,DAL6,DRM/ &
      -21.2666329d0,   &
      32.24527521d0,-6.062894078d0,7.515660734d0,233.7341288d0,-227.1195714d0,      &
      8.483233889d0,16.80642754d0,-24.63534184d0,9.067120578d0,-1.052686913d0,      &
      -12.08384538d0,18.61969572d0,-12.71686069d0,47017.35679d0,-50646.71204d0, &
      7746.058231d0,1.531069371d0,2.318824273d0,.1417519429d0,.6388013110d-02, &
      5.303934488d0,4.213397467d0,.7955534018d0,.1401142771d0,.2306094179d-01, &
      3.462235072d0,2.568743010d0,3.477425908d0,1.922155110d0,.1485233485d0, &
      .2319676273d-01,7.830223587d0,8.492933868d0,.1295221828d0,.01753008801d0, &
      .01125504083d0,.1811846095d0,.04841237481d0,.01981805097d0,6.557801891d0, &
      6.348576071d0,5.744436687d0,.2265212965d0,.1301957209d0,.5654023158d0/

        SINT2=SINT**2
        COST2=COST**2
        SC=SINT*COST
        ALPHA=SINT2/R
        GAMMA=COST/R**2

        CALL FFS(ALPHA,AL1,DAL1,F,FA,FS)
        D1=SC*F**XK1/((R/B1)**BE1+1.D0)
        D2=D1*COST2

        CALL FFS(ALPHA,AL2,DAL2,F,FA,FS)
        D3=SC*FS**XK2/((R/B2)**BE2+1.D0)
        D4=D3*COST2

        CALL FFS(ALPHA,AL3,DAL3,F,FA,FS)
        D5=SC*(ALPHA**XK3)*(FS**XK4)/((R/B3)**BE3+1.D0)
        D6=D5*COST2

        ARGA=((ALPHA-AL4)/DAL4)**2+1.D0
        ARGG=1.D0+(GAMMA/DG1)**2

        D7=SC/ARGA/ARGG
        D8=D7/ARGA
        D9=D8/ARGA
        D10=D9/ARGA

        ARGA=((ALPHA-AL5)/DAL5)**2+1.D0
        ARGG=1.D0+(GAMMA/DG2)**2

        D11=SC/ARGA/ARGG
        D12=D11/ARGA
        D13=D12/ARGA
        D14=D13/ARGA


        D15=SC/(R**4+C1**4)
        D16=SC/(R**4+C2**4)*COST2
        D17=SC/(R**4+C3**4)*COST2**2

        CALL FFS(ALPHA,AL6,DAL6,F,FA,FS)
        D18=SC*FS/(1.D0+((R-1.2D0)/DRM)**2)

        BR_PRC_Q=A1*D1+A2*D2+A3*D3+A4*D4+A5*D5+A6*D6+A7*D7+A8*D8+A9*D9+ &
        A10*D10+A11*D11+A12*D12+A13*D13+A14*D14+A15*D15+A16*D16+A17*D17+ &
         A18*D18
!
        RETURN
        END
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
        DOUBLE PRECISION FUNCTION BT_PRC_Q (R,SINT,COST)
!
!alculates the Theta component of the "quadrupole" part of the model partial ring current.
!
        IMPLICIT  REAL * 8  (A - H, O - Z)
      save

! ALL LINEAR PARAMETERS HERE
! WERE MULTIPLIED BY 0.1,
! SO THAT THEY CORRESPOND TO P_0=1 nPa,
! RATHER THAN THE ORIGINAL VALUE OF 10 nPa
! ASSUMED IN THE BIOT-SAVART INTEGRAL

      DATA A1,A2,A3,A4,A5,A6,A7,A8,A9,A10,A11,A12,A13,A14,A15,A16,A17, &
      XK1,AL1,DAL1,B1,BE1,XK2,AL2,DAL2,BE2,XK3,XK4,AL3,DAL3,B3,BE3,AL4,&
      DAL4,DG1,AL5,DAL5,DG2,C1,C2,C3/ &
      12.74640393d0,-7.516393516d0,           &
      -5.476233865d0,3.212704645d0,-59.10926169d0,46.62198189d0,-.01644280062d0,   &
      .1234229112d0,-.08579198697d0,.01321366966d0,.8970494003d0,9.136186247d0,    &
      -38.19301215d0,21.73775846d0,-410.0783424d0,-69.90832690d0,-848.8543440d0, &
      1.243288286d0,.2071721360d0,.05030555417d0,7.471332374d0,3.180533613d0, &
      1.376743507d0,.1568504222d0,.02092910682d0,1.985148197d0,.3157139940d0, &
      1.056309517d0,.1701395257d0,.1019870070d0,6.293740981d0,5.671824276d0, &
      .1280772299d0,.02189060799d0,.01040696080d0,.1648265607d0,.04701592613d0, &
      .01526400086d0,12.88384229d0,3.361775101d0,23.44173897d0/

        SINT2=SINT**2
        COST2=COST**2
! jah, foresys : Result of assignment to SC is not used
! jah,        SC=SINT*COST
        ALPHA=SINT2/R
        GAMMA=COST/R**2

        CALL FFS(ALPHA,AL1,DAL1,F,FA,FS)
        D1=F**XK1/((R/B1)**BE1+1.D0)
        D2=D1*COST2

        CALL FFS(ALPHA,AL2,DAL2,F,FA,FS)
        D3=FA**XK2/R**BE2
        D4=D3*COST2

        CALL FFS(ALPHA,AL3,DAL3,F,FA,FS)
        D5=FS**XK3*ALPHA**XK4/((R/B3)**BE3+1.D0)
        D6=D5*COST2

        CALL FFS(GAMMA,0.D0,DG1,F,FA,FS)
        FCC=(1.D0+((ALPHA-AL4)/DAL4)**2)
        D7 =1.D0/FCC*FS
        D8 =D7/FCC
        D9 =D8/FCC
        D10=D9/FCC

        ARG=1.D0+((ALPHA-AL5)/DAL5)**2
        D11=1.D0/ARG/(1.D0+(GAMMA/DG2)**2)
        D12=D11/ARG
        D13=D12/ARG
        D14=D13/ARG

        D15=1.D0/(R**4+C1**2)
        D16=COST2/(R**4+C2**2)
        D17=COST2**2/(R**4+C3**2)
!
        BT_PRC_Q=A1*D1+A2*D2+A3*D3+A4*D4+A5*D5+A6*D6+A7*D7+A8*D8+A9*D9+ &
         A10*D10+A11*D11+A12*D12+A13*D13+A14*D14+A15*D15+A16*D16+A17*D17
!
       RETURN
       END
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

       SUBROUTINE FFS(A,A0,DA,F,FA,FS)
       IMPLICIT  REAL * 8  (A - H, O - Z)
      save
       SQ1=DSQRT((A+A0)**2+DA**2)
       SQ2=DSQRT((A-A0)**2+DA**2)
       FA=2.D0/(SQ1+SQ2)
       F=FA*A
       FS=0.5D0*(SQ1+SQ2)/(SQ1*SQ2)*(1.D0-F*F)
       RETURN
       END
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
         SUBROUTINE RC_SHIELD (A,PS,X_SC,X,Y,Z,BX,BY,BZ)
!
!   COMPUTES THE COMPONENTS OF THE SHIELDING FIELD FOR THE RING CURRENT
!       (EITHER PARTIAL OR AXISYMMETRICAL)
!   INPUT:   A - AN ARRAY CONTAINING THE HARMONIC COEFFICIENTS AND NONLINEAR PARAMETERS
!            PS - GEODIPOLE TILT ANGLE IN RADIANS
!            X_SC - SCALING FACTOR ( X_SC> 1 AND X_SC< 1 CORRESPOND TO LARGER/SMALLER
!                  RING CURRENT, RESP.)
!            X,Y,Z - POSITION IN RE (GSM COORDS)
!   OUTPUT:  BX,BY,BZ - SHIELDING FIELD COMPONENTS (GSM)
!
       IMPLICIT  REAL * 8  (A - H, O - Z)
         DIMENSION A(86)
      save
!
         FAC_SC=(X_SC+1.D0)**3
!
         CPS=DCOS(PS)
         SPS=DSIN(PS)

         S3PS=2.D0*CPS
!
         PST1=PS*A(85)
         PST2=PS*A(86)

         ST1=DSIN(PST1)
         CT1=DCOS(PST1)
         ST2=DSIN(PST2)
         CT2=DCOS(PST2)

         X1=X*CT1-Z*ST1
         Z1=X*ST1+Z*CT1
         X2=X*CT2-Z*ST2
         Z2=X*ST2+Z*CT2
!
         L=0
         GX=0.D0
         GY=0.D0
         GZ=0.D0
!
         DO 1 M=1,2     !    M=1 IS FOR THE 1ST SUM ("PERP." SYMMETRY)
!                           AND M=2 IS FOR THE SECOND SUM ("PARALL." SYMMETRY)
             DO 2 I=1,3
                  P=A(72+I)
                  Q=A(78+I)
                  CYPI=DCOS(Y/P)
                  CYQI=DCOS(Y/Q)
                  SYPI=DSIN(Y/P)
                  SYQI=DSIN(Y/Q)
!
                DO 3 K=1,3
                   R=A(75+K)
                   S=A(81+K)
                   SZRK=DSIN(Z1/R)
                   CZSK=DCOS(Z2/S)
                   CZRK=DCOS(Z1/R)
                   SZSK=DSIN(Z2/S)
                     SQPR=DSQRT(1.D0/P**2+1.D0/R**2)
                     SQQS=DSQRT(1.D0/Q**2+1.D0/S**2)
                        EPR=DEXP(X1*SQPR)
                        EQS=DEXP(X2*SQQS)
!
                  DO 4 N=1,2  ! N=1 IS FOR THE FIRST PART OF EACH COEFFICIENT
!                                AND N=2 IS FOR THE SECOND ONE

                    DO 5 NN=1,2 !   NN = 1,2 FURTHER SPLITS THE COEFFICIENTS INTO 2 PARTS,
!                                         TO TAKE INTO ACCOUNT THE SCALE FACTOR DEPENDENCE

                    IF (M.EQ.1) THEN
                         FX=-SQPR*EPR*CYPI*SZRK  *FAC_SC
                         FY=EPR*SYPI*SZRK/P   *FAC_SC
                         FZ=-EPR*CYPI*CZRK/R  *FAC_SC
                       IF (N.EQ.1) THEN
                         IF (NN.EQ.1) THEN
                          HX=FX
                          HY=FY
                          HZ=FZ
                         ELSE
                          HX=FX*X_SC
                          HY=FY*X_SC
                          HZ=FZ*X_SC
                         ENDIF
                       ELSE
                         IF (NN.EQ.1) THEN
                          HX=FX*CPS
                          HY=FY*CPS
                          HZ=FZ*CPS
                         ELSE
                          HX=FX*CPS*X_SC
                          HY=FY*CPS*X_SC
                          HZ=FZ*CPS*X_SC
                         ENDIF
                       ENDIF

                     ELSE                            !   M.EQ.2
                         FX=-SPS*SQQS*EQS*CYQI*CZSK  *FAC_SC
                         FY=SPS/Q*EQS*SYQI*CZSK   *FAC_SC
                         FZ=SPS/S*EQS*CYQI*SZSK   *FAC_SC
                       IF (N.EQ.1) THEN
                        IF (NN.EQ.1) THEN
                          HX=FX
                          HY=FY
                          HZ=FZ
                        ELSE
                          HX=FX*X_SC
                          HY=FY*X_SC
                          HZ=FZ*X_SC
                        ENDIF
                       ELSE
                        IF (NN.EQ.1) THEN
                         HX=FX*S3PS
                         HY=FY*S3PS
                         HZ=FZ*S3PS
                        ELSE
                         HX=FX*S3PS*X_SC
                         HY=FY*S3PS*X_SC
                         HZ=FZ*S3PS*X_SC
                        ENDIF
                       ENDIF
                  ENDIF
       L=L+1

       IF (M.EQ.1) THEN
       HXR=HX*CT1+HZ*ST1
       HZR=-HX*ST1+HZ*CT1
       ELSE
       HXR=HX*CT2+HZ*ST2
       HZR=-HX*ST2+HZ*CT2
       ENDIF

       GX=GX+HXR*A(L)
       GY=GY+HY *A(L)
  5    GZ=GZ+HZR*A(L)

  4   CONTINUE
  3   CONTINUE
  2   CONTINUE
  1   CONTINUE

      BX=GX
      BY=GY
      BZ=GZ

      RETURN
      END
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
      SUBROUTINE DIPOLE (PS,X,Y,Z,BX,BY,BZ)
!
!     THIS IS A DOUBLE PRECISION ROUTINE, OTHERWISE IDENTICAL TO THE S/R DIP OF GEOPACK
!
!     CALCULATES GSM COMPONENTS OF A GEODIPOLE FIELD WITH THE DIPOLE MOMENT
!     CORRESPONDING TO THE EPOCH OF 2000.
!
!------INPUT PARAMETERS:
!       PS - GEODIPOLE TILT ANGLE IN RADIANS,
!       X,Y,Z - GSM COORDINATES IN RE (1 RE = 6371.2 km)
!
!----OUTPUT PARAMETERS:
!     BX,BY,BZ - FIELD COMPONENTS IN GSM SYSTEM, IN NANOTESLA.
!
!    LAST MODIFICATION: JAN. 5, 2001. THE VALUE OF THE DIPOLE MOMENT WAS UPDATED TO 2000.
!      AND A "SAVE" STATEMENT HAS BEEN ADDED, TO AVOID POTENTIAL PROBLEMS WITH SOME
!      FORTRAN COMPILERS
!
!    WRITTEN BY: N. A. TSYGANENKO
!
      IMPLICIT REAL*8 (A-H,O-Z)
      save
!!!      SAVE M,PSI
      DATA M,PSI/0,5.D0/
      IF(M.EQ.1.AND.DABS(PS-PSI).LT.1.D-5) GOTO 1   !   THIS IS TO AVOID MULTIPLE CALCULATIONS
      SPS=DSIN(PS)                                  !   OF SIN(PS) AND COS(PS), IF THE ANGLE PS
      CPS=DCOS(PS)                                  !   REMAINS UNCHANGED
      PSI=PS
      M=1
  1   P=X**2
      U=Z**2
      V=3.D0*Z*X
      T=Y**2
      Q=30115.D0/DSQRT(P+T+U)**5
      BX=Q*((T+U-2.D0*P)*SPS-V*CPS)
      BY=-3.D0*Y*Q*(X*SPS+Z*CPS)
      BZ=Q*((P+T-2.D0*U)*CPS-V*SPS)
      RETURN
      END


!     Fin du modele T01_01
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

!
!     Debut du modele T04_s, fichier Ts04.txt, telecharger le 17/11/05
!
      SUBROUTINE T04_s (IOPT,PARMOD,PS,X,Y,Z,BX,BY,BZ)
!
!     ASSEMBLED:  MARCH 25, 2004; UPDATED:  AUGUST 2 & 31, DECEMBER 27, 2004.
!
!--------------------------------------------------------------------
!   A DATA-BASED MODEL OF THE EXTERNAL (I.E., WITHOUT EARTH'S CONTRIBUTION) PART OF THE
!   MAGNETOSPHERIC MAGNETIC FIELD, CALIBRATED BY
!    (1) SOLAR WIND PRESSURE PDYN (NANOPASCALS),
!    (2) DST (NANOTESLA),
!    (3) BYIMF,
!    (4) BZIMF (NANOTESLA)
!    (5-10)   INDICES W1 - W6, CALCULATED AS TIME INTEGRALS FROM THE BEGINNING OF A STORM
!               SEE THE REFERENCE (3) BELOW, FOR A DETAILED DEFINITION OF THOSE VARIABLES
!
!   THE ABOVE 10 INPUT PARAMETERS SHOULD BE PLACED IN THE ELEMENTS
!   OF THE ARRAY PARMOD(10).
!
!   THE REST OF THE INPUT VARIABLES ARE: THE GEODIPOLE TILT ANGLE PS (RADIANS),
!        X,Y,Z -  GSM POSITION (RE)
!
!   IOPT IS A DUMMY INPUT PARAMETER, INCLUDED TO MAKE THIS SUBROUTINE
!   COMPATIBLE WITH THE TRACING SOFTWARE PACKAGE (GEOPACK). IN THIS MODEL,
!   THE PARAMETER IOPT DOES NOT AFFECT THE OUTPUT FIELD.
!
!*******************************************************************************************
!** ATTENTION:  THE MODEL IS BASED ON DATA TAKEN SUNWARD FROM X=-15Re, AND HENCE BECOMES   *
!**              INVALID AT LARGER TAILWARD DISTANCES !!!                                  *
!*******************************************************************************************
!
!   OUTPUT:  GSM COMPONENTS OF THE EXTERNAL MAGNETIC FIELD (BX,BY,BZ, nanotesla)
!            COMPUTED AS A SUM OF CONTRIBUTIONS FROM PRINCIPAL FIELD SOURCES
!
!  (C) Copr. 2004, Nikolai A. Tsyganenko, USRA/Code 695.1, NASA GSFC
!      Greenbelt, MD 20771, USA
!
!                            REFERENCES:
!
!  (1)   N. A. Tsyganenko, A new data-based model of the near magnetosphere magnetic field:
!       1. Mathematical structure.
!       2. Parameterization and fitting to observations.  JGR v. 107(A8), 1176/1179, doi:10.1029/2001JA000219/220, 2002.
!
!  (2)  N. A. Tsyganenko, H. J. Singer, J. C. Kasper, Storm-time distortion of the
!           inner magnetosphere: How severe can it get ?  JGR v. 108(A5), 1209, doi:10.1029/2002JA009808, 2003.

!   (3)  N. A. Tsyganenko and M. I. Sitnov, Modeling the dynamics of the inner
!           magnetosphere during strong geomagnetic storms,  JGR v. 110, 2005, in press.
!----------------------------------------------------------------------
!
      save
      REAL PARMOD(10),PS,X,Y,Z,BX,BY,BZ
      REAL*8 A(69),PDYN,DST_AST,BXIMF,BYIMF,BZIMF,W1,W2,W3,W4,W5,W6, &
        PSS,XX,YY,ZZ,BXCF,BYCF,BZCF,BXT1,BYT1,BZT1,BXT2,BYT2,BZT2, &
        BXSRC,BYSRC,BZSRC,BXPRC,BYPRC,BZPRC, BXR11,BYR11,BZR11, &
        BXR12,BYR12,BZR12,BXR21,BYR21,BZR21,BXR22,BYR22,BZR22,HXIMF, &
        HYIMF,HZIMF,BBX,BBY,BBZ
!
      DATA A/1.00000d0,5.19884d0,0.923524d0,8.68111d0,0.00000d0,-6.44922d0,11.3109d0, &
       -3.84555d0,0.00000d0,0.558081d0,0.937044d0,0.00000d0,0.772433d0,0.687241d0, &
       0.00000d0,0.320369d0,1.22531d0,-0.432246d-01,-0.382436d0,0.457468d0, &
       0.741917d0,0.227194d0,0.154269d0,5.75196d0,22.3113d0,10.3526d0,64.3312d0, &
       1.01977d0,-0.200859d-01,0.971643d0,0.295525d-01,1.01032d0,0.215561d0, &
       1.50059d0,0.730898d-01,1.93625d0,1.74545d0,1.29533d0,0.714744d0,0.391687d0, &
       3.31283d0,75.0127d0,6.36283d0,4.43561d0,0.387801d0,0.699661d0,0.305352d-01, &
       0.581002d0,1.14671d0,0.876060d0,0.386060d0,0.801831d0,0.874315d0,0.463634d0, &
       0.175077d0,0.673053d0,0.388341d0,2.32074d0,1.32373d0,0.419800d0,1.24968d0, &
       1.28903d0,.409286d0,1.57622d0,.690036d0,1.28836d0,2.4054d0,.528557d0,.564247d0/

      DATA IOPGEN,IOPTT,IOPB,IOPR/0,0,0,0/

! inutile
iopt=0
!
      PDYN=dble(PARMOD(1))
      DST_AST=dble(PARMOD(2)*0.8-13.*SQRT(sngl(PDYN)))
      BYIMF=dble(PARMOD(3))
      BZIMF=dble(PARMOD(4))

      W1=dble(PARMOD (5))
      W2=dble(PARMOD (6))
      W3=dble(PARMOD (7))
      W4=dble(PARMOD (8))
      W5=dble(PARMOD (9))
      W6=dble(PARMOD(10))

      PSS=dble(PS)
      XX=dble(X)
      YY=dble(Y)
      ZZ=dble(Z)
!
      CALL EXTERN (IOPGEN,IOPTT,IOPB,IOPR,A,79,PDYN,DST_AST,BXIMF,BYIMF, &
       BZIMF,W1,W2,W3,W4,W5,W6,PSS,XX,YY,ZZ,BXCF,BYCF,BZCF,BXT1,BYT1, &
       BZT1,BXT2,BYT2,BZT2,BXSRC,BYSRC,BZSRC,BXPRC,BYPRC,BZPRC, BXR11, &
       BYR11,BZR11,BXR12,BYR12,BZR12,BXR21,BYR21,BZR21,BXR22,BYR22, &
       BZR22,HXIMF,HYIMF,HZIMF,BBX,BBY,BBZ)
!
! jah, foresys : Precision loss in assignment from real*8 to real
! jah,      BX=BBX
      BX=sngl(BBX)
! jah, foresys : Precision loss in assignment from real*8 to real
! jah,      BY=BBY
      BY=sngl(BBY)
! jah, foresys : Precision loss in assignment from real*8 to real
! jah,      BZ=BBZ
      BZ=sngl(BBZ)
!
      RETURN
      END

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
      SUBROUTINE EXTERN (IOPGEN,IOPT,IOPB,IOPR,A,NTOT, &
        PDYN,DST,BXIMF,BYIMF,BZIMF,W1,W2,W3,W4,W5,W6,PS,X,Y,Z, &
        BXCF,BYCF,BZCF,BXT1,BYT1,BZT1,BXT2,BYT2,BZT2, &
        BXSRC,BYSRC,BZSRC,BXPRC,BYPRC,BZPRC, BXR11,BYR11,BZR11, &
        BXR12,BYR12,BZR12,BXR21,BYR21,BZR21,BXR22,BYR22,BZR22,HXIMF, &
        HYIMF,HZIMF,BX,BY,BZ)

!
!   IOPGEN - GENERAL OPTION FLAG:  IOPGEN=0 - CALCULATE TOTAL FIELD
!                                  IOPGEN=1 - DIPOLE SHIELDING ONLY
!                                  IOPGEN=2 - TAIL FIELD ONLY
!                                  IOPGEN=3 - BIRKELAND FIELD ONLY
!                                  IOPGEN=4 - RING CURRENT FIELD ONLY
!                                  IOPGEN=5 - INTERCONNECTION FIELD ONLY
!
!   IOPT -  TAIL FIELD FLAG:       IOPT=0  -  BOTH MODES
!                                  IOPT=1  -  MODE 1 ONLY
!                                  IOPT=2  -  MODE 2 ONLY
!
!   IOPB -  BIRKELAND FIELD FLAG:  IOPB=0  -  ALL 4 TERMS
!                                  IOPB=1  -  REGION 1, MODES 1 AND 2
!                                  IOPB=2  -  REGION 2, MODES 1 AND 2
!
!   IOPR -  RING CURRENT FLAG:     IOPR=0  -  BOTH SRC AND PRC
!                                  IOPR=1  -  SRC ONLY
!                                  IOPR=2  -  PRC ONLY
!
      IMPLICIT  REAL * 8  (A - H, O - Z)
!
      DIMENSION A(NTOT)
      save
!
      COMMON /TAIL/ DXSHIFT1,DXSHIFT2,D,DELTADY  ! THE COMMON BLOCKS FORWARD NONLINEAR PARAMETERS
      COMMON /BIRKPAR/ XKAPPA1,XKAPPA2
      COMMON /RCPAR/ SC_SY,SC_AS,PHI
      COMMON /G/ G
      COMMON /RH0_T04/ RH0
!
!
      DATA A0_A,A0_S0,A0_X0 /34.586D0,1.1960D0,3.4397D0/   !   SHUE ET AL. PARAMETERS
      DATA DSIG /0.005D0/, RH0,RH2 /7.5D0,-5.2D0/
! inutile
  BXIMF=0.d0
!
      XAPPA=(PDYN/2.d0)**A(23)   !  OVERALL SCALING PARAMETER
      RH0=7.5d0                  !  TAIL HINGING DISTANCE
!
      G=  35.0d0                 !  TAIL WARPING PARAMETER

      XAPPA3=XAPPA**3

      XX=X*XAPPA
      YY=Y*XAPPA
      ZZ=Z*XAPPA
!
      SPS=DSIN(PS)
!
      X0=A0_X0/XAPPA
      AM=A0_A/XAPPA
      S0=A0_S0
!
!  CALCULATE "IMF" COMPONENTS OUTSIDE THE MAGNETOPAUSE LAYER (HENCE BEGIN WITH "O")
!  THEY ARE NEEDED ONLY IF THE POINT (X,Y,Z) IS WITHIN THE TRANSITION MAGNETOPAUSE LAYER
!  OR OUTSIDE THE MAGNETOSPHERE:
!
      FACTIMF=A(20)
!
      OIMFX=0.D0
      OIMFY=BYIMF*FACTIMF
      OIMFZ=BZIMF*FACTIMF
!
      R=DSQRT(X**2+Y**2+Z**2)
      XSS=X
      ZSS=Z

  1   XSOLD=XSS      !   BEGIN ITERATIVE SEARCH OF UNWARPED COORDS (TO FIND SIGMA)
      ZSOLD=ZSS

      RH=RH0+RH2*(ZSS/R)**2
      SINPSAS=SPS/(1.D0+(R/RH)**3)**0.33333333D0
      COSPSAS=DSQRT(1.D0-SINPSAS**2)
      ZSS=X*SINPSAS+Z*COSPSAS
      XSS=X*COSPSAS-Z*SINPSAS
      DD=DABS(XSS-XSOLD)+DABS(ZSS-ZSOLD)
      IF (DD.GT.1.D-6) GOTO 1
!                                END OF ITERATIVE SEARCH
      RHO2=Y**2+ZSS**2
      ASQ=AM**2
      XMXM=AM+XSS-X0
      IF (XMXM.LT.0.d0) XMXM=0.d0 ! THE BOUNDARY IS A CYLINDER TAILWARD OF X=X0-AM
      AXX0=XMXM**2
      ARO=ASQ+RHO2
      SIGMA=DSQRT((ARO+AXX0+SQRT((ARO+AXX0)**2-4.d0*ASQ*AXX0))/(2.d0*ASQ))
!
!   NOW, THERE ARE THREE POSSIBLE CASES:
!    (1) INSIDE THE MAGNETOSPHERE   (SIGMA
!    (2) IN THE BOUNDARY LAYER
!    (3) OUTSIDE THE MAGNETOSPHERE AND B.LAYER
!       FIRST OF ALL, CONSIDER THE CASES (1) AND (2):
!
!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      IF (SIGMA.LT.S0+DSIG) THEN  !  CASES (1) OR (2); CALCULATE THE MODEL FIELD
!                                   (WITH THE POTENTIAL "PENETRATED" INTERCONNECTION FIELD):
!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!
      IF (IOPGEN.LE.1) THEN
         CALL SHLCAR3X3_T04(XX,YY,ZZ,PS,CFX,CFY,CFZ)         !  DIPOLE SHIELDING FIELD
         BXCF=CFX*XAPPA3
         BYCF=CFY*XAPPA3
         BZCF=CFZ*XAPPA3
      ELSE
         BXCF=0.D0
         BYCF=0.D0
         BZCF=0.D0
      ENDIF                                              !  DONE

      IF (IOPGEN.EQ.0.OR.IOPGEN.EQ.2) THEN
          DSTT=-20.d0
          IF (DST.LT.DSTT) DSTT=DST
          ZNAM=DABS(DSTT)**0.37d0
         DXSHIFT1=A(24)-A(25)/ZNAM
         DXSHIFT2=A(26)-A(27)/ZNAM
         D=A(36)*DEXP(-W1/A(37))  +A(69)
         DELTADY=4.7d0

         CALL DEFORMED_T04 (IOPT,PS,XX,YY,ZZ,                 &!  TAIL FIELD (THREE MODES)
          BXT1,BYT1,BZT1,BXT2,BYT2,BZT2)
      ELSE
         BXT1=0.D0
         BYT1=0.D0
         BZT1=0.D0
         BXT2=0.D0
         BYT2=0.D0
         BZT2=0.D0
      ENDIF

      IF (IOPGEN.EQ.0.OR.IOPGEN.EQ.3) THEN

          ZNAM=DABS(DST)
          IF (DST.GE.-20.D0) ZNAM=20.D0
          XKAPPA1=A(32)*(ZNAM/20.D0)**A(33)
          XKAPPA2=A(34)*(ZNAM/20.D0)**A(35)

         CALL BIRK_TOT_T04 (IOPB,PS,XX,YY,ZZ,BXR11,BYR11,BZR11,BXR12, &
               BYR12, &
         BZR12,BXR21,BYR21,BZR21,BXR22,BYR22,BZR22)    !   BIRKELAND FIELD (TWO MODES FOR R1 AND TWO MODES FOR R2)
      ELSE
         BXR11=0.D0
         BYR11=0.D0
         BZR11=0.D0
         BXR21=0.D0
         BYR21=0.D0
         BZR21=0.D0
      ENDIF

      IF (IOPGEN.EQ.0.OR.IOPGEN.EQ.4) THEN
         PHI=A(38)

          ZNAM=DABS(DST)
          IF (DST.GE.-20.D0) ZNAM=20.D0
          SC_SY=A(28)*(20.D0/ZNAM)**A(29) *XAPPA    !
          SC_AS=A(30)*(20.D0/ZNAM)**A(31) *XAPPA    !  MULTIPLICATION  BY XAPPA IS MADE IN ORDER TO MAKE THE SRC AND PRC
                                                    !     SCALING COMPLETELY INDEPENDENT OF THE GENERAL SCALING DUE TO THE
!                                                         MAGNETOPAUSE COMPRESSION/EXPANSION                             !
!
         CALL FULL_RC_T04(IOPR,PS,XX,YY,ZZ,BXSRC,BYSRC,BZSRC,BXPRC, &
               BYPRC, &
                                              BZPRC)  !  SHIELDED RING CURRENT (SRC AND PRC)
      ELSE
         BXSRC=0.D0
         BYSRC=0.D0
         BZSRC=0.D0
         BXPRC=0.D0
         BYPRC=0.D0
         BZPRC=0.D0
      ENDIF
!
      IF (IOPGEN.EQ.0.OR.IOPGEN.EQ.5) THEN
         HXIMF=0.D0
         HYIMF=BYIMF
         HZIMF=BZIMF   ! THESE ARE COMPONENTS OF THE PENETRATED FIELD PER UNIT OF THE PENETRATION COEFFICIENT.
!                             IN OTHER WORDS, THESE ARE DERIVATIVES OF THE PENETRATION FIELD COMPONENTS WITH RESPECT
!                             TO THE PENETRATION COEFFICIENT.   WE ASSUME THAT ONLY TRANSVERSE COMPONENT OF THE
!                             FIELD PENETRATES INSIDE.
       ELSE
         HXIMF=0.D0
         HYIMF=0.D0
         HZIMF=0.D0
       ENDIF
!
!-----------------------------------------------------------
!
!    NOW, ADD UP ALL THE COMPONENTS:
!
      DLP1=(PDYN/2.D0)**A(21)
      DLP2=(PDYN/2.D0)**A(22)

      TAMP1=A(2)+A(3)*DLP1+A(4)*A(39)*W1/DSQRT(W1**2+A(39)**2)+A(5)*DST
      TAMP2=A(6)+A(7)*DLP2+A(8)*A(40)*W2/DSQRT(W2**2+A(40)**2)+A(9)*DST
      A_SRC=A(10)+A(11)*A(41)*W3/DSQRT(W3**2+A(41)**2) &
        +A(12)*DST
      A_PRC=A(13)+A(14)*A(42)*W4/DSQRT(W4**2+A(42)**2) &
        +A(15)*DST
      A_R11=A(16)+A(17)*A(43)*W5/DSQRT(W5**2+A(43)**2)
      A_R21=A(18)+A(19)*A(44)*W6/DSQRT(W6**2+A(44)**2)

      BBX=A(1)*BXCF+TAMP1*BXT1+TAMP2*BXT2+A_SRC*BXSRC+A_PRC*BXPRC &
       +A_R11*BXR11+A_R21*BXR21+A(20)*HXIMF

      BBY=A(1)*BYCF+TAMP1*BYT1+TAMP2*BYT2+A_SRC*BYSRC+A_PRC*BYPRC &
       +A_R11*BYR11+A_R21*BYR21+A(20)*HYIMF

      BBZ=A(1)*BZCF+TAMP1*BZT1+TAMP2*BZT2+A_SRC*BZSRC+A_PRC*BZPRC &
       +A_R11*BZR11+A_R21*BZR21+A(20)*HZIMF
!
!   AND WE HAVE THE TOTAL EXTERNAL FIELD.
!
!
!  NOW, LET US CHECK WHETHER WE HAVE THE CASE (1). IF YES - ALL DONE:
!
      IF (SIGMA.LT.S0-DSIG) THEN    !  (X,Y,Z) IS INSIDE THE MAGNETOSPHERE

       BX=BBX
       BY=BBY
       BZ=BBZ
                     ELSE           !  THIS IS THE MOST COMPLEX CASE: WE ARE INSIDE
!                                             THE INTERPOLATION REGION
       FINT=0.5d0*(1.d0-(SIGMA-S0)/DSIG)
       FEXT=0.5d0*(1.d0+(SIGMA-S0)/DSIG)
!
       CALL DIPOLE_T04 (PS,X,Y,Z,QX,QY,QZ)
       BX=(BBX+QX)*FINT+OIMFX*FEXT -QX
       BY=(BBY+QY)*FINT+OIMFY*FEXT -QY
       BZ=(BBZ+QZ)*FINT+OIMFZ*FEXT -QZ
!
        ENDIF  !   THE CASES (1) AND (2) ARE EXHAUSTED; THE ONLY REMAINING
!                      POSSIBILITY IS NOW THE CASE (3):
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
        ELSE
                CALL DIPOLE_T04 (PS,X,Y,Z,QX,QY,QZ)
                BX=OIMFX-QX
                BY=OIMFY-QY
                BZ=OIMFZ-QZ
        ENDIF
!
      END
!

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
         SUBROUTINE  SHLCAR3X3_T04(X,Y,Z,PS,BX,BY,BZ)
!
!   THIS S/R RETURNS THE SHIELDING FIELD FOR THE EARTH'S DIPOLE,
!   REPRESENTED BY  2x3x3=18 "CARTESIAN" HARMONICS, tilted with respect
!   to the z=0 plane
!
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  The 36 coefficients enter in pairs in the amplitudes of the "cartesian"
!    harmonics (A(1)-A(36).
!  The 14 nonlinear parameters (A(37)-A(50) are the scales Pi,Ri,Qi,and Si
!   entering the arguments of exponents, sines, and cosines in each of the
!   18 "Cartesian" harmonics  PLUS TWO TILT ANGLES FOR THE CARTESIAN HARMONICS
!       (ONE FOR THE PSI=0 MODE AND ANOTHER FOR THE PSI=90 MODE)
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!
      IMPLICIT  REAL * 8  (A - H, O - Z)
!
      DIMENSION A(50)
      save
      DATA A/-901.2327248d0,895.8011176d0,817.6208321d0,-845.5880889d0, &
      -83.73539535d0,86.58542841d0,336.8781402d0,-329.3619944d0,-311.2947120d0, &
      308.6011161d0,31.94469304d0,-31.30824526d0,125.8739681d0,-372.3384278d0, &
      -235.4720434d0,286.7594095d0,21.86305585d0,-27.42344605d0,-150.4874688d0, &
      2.669338538d0,1.395023949d0,-.5540427503d0,-56.85224007d0,3.681827033d0, &
      -43.48705106d0,5.103131905d0,1.073551279d0,-.6673083508d0,12.21404266d0, &
      4.177465543d0,5.799964188d0,-.3977802319d0,-1.044652977d0,.5703560010d0, &
      3.536082962d0,-3.222069852d0,9.620648151d0,6.082014949d0,27.75216226d0, &
      12.44199571d0,5.122226936d0,6.982039615d0,20.12149582d0,6.150973118d0, &
      4.663639687d0,15.73319647d0,2.303504968d0,5.840511214d0,.8385953499d-01, &
      .3477844929d0/
!
         P1=A(37)
         P2=A(38)
         P3=A(39)
         R1=A(40)
         R2=A(41)
         R3=A(42)
         Q1=A(43)
         Q2=A(44)
         Q3=A(45)
         S1=A(46)
         S2=A(47)
         S3=A(48)

         T1  =A(49)
         T2  =A(50)
!
         CPS=DCOS(PS)
         SPS=DSIN(PS)
         S2PS=2.D0*CPS

!
           ST1=DSIN(PS*T1)
           CT1=DCOS(PS*T1)
           ST2=DSIN(PS*T2)
           CT2=DCOS(PS*T2)

            X1=X*CT1-Z*ST1
            Z1=X*ST1+Z*CT1
            X2=X*CT2-Z*ST2
            Z2=X*ST2+Z*CT2
!
!
!  MAKE THE TERMS IN THE 1ST SUM ("PERPENDICULAR" SYMMETRY):
!
!       I=1
!
        SQPR= DSQRT(1.D0/P1**2+1.D0/R1**2)
        CYP = DCOS(Y/P1)
        SYP = DSIN(Y/P1)
        CZR = DCOS(Z1/R1)
        SZR = DSIN(Z1/R1)
        EXPR= DEXP(SQPR*X1)
        FX1 =-SQPR*EXPR*CYP*SZR
        HY1 = EXPR/P1*SYP*SZR
        FZ1 =-EXPR*CYP/R1*CZR
        HX1 = FX1*CT1+FZ1*ST1
        HZ1 =-FX1*ST1+FZ1*CT1

        SQPR= DSQRT(1.D0/P1**2+1.D0/R2**2)
        CYP = DCOS(Y/P1)
        SYP = DSIN(Y/P1)
        CZR = DCOS(Z1/R2)
        SZR = DSIN(Z1/R2)
        EXPR= DEXP(SQPR*X1)
        FX2 =-SQPR*EXPR*CYP*SZR
        HY2 = EXPR/P1*SYP*SZR
        FZ2 =-EXPR*CYP/R2*CZR
        HX2 = FX2*CT1+FZ2*ST1
        HZ2 =-FX2*ST1+FZ2*CT1

        SQPR= DSQRT(1.D0/P1**2+1.D0/R3**2)
        CYP = DCOS(Y/P1)
        SYP = DSIN(Y/P1)
        CZR = DCOS(Z1/R3)
        SZR = DSIN(Z1/R3)
        EXPR= DEXP(SQPR*X1)
        FX3 =-EXPR*CYP*(SQPR*Z1*CZR+SZR/R3*(X1+1.D0/SQPR))
        HY3 = EXPR/P1*SYP*(Z1*CZR+X1/R3*SZR/SQPR)
        FZ3 =-EXPR*CYP*(CZR*(1.D0+X1/R3**2/SQPR)-Z1/R3*SZR)
        HX3 = FX3*CT1+FZ3*ST1
        HZ3 =-FX3*ST1+FZ3*CT1
!
!       I=2:
!
        SQPR= DSQRT(1.D0/P2**2+1.D0/R1**2)
        CYP = DCOS(Y/P2)
        SYP = DSIN(Y/P2)
        CZR = DCOS(Z1/R1)
        SZR = DSIN(Z1/R1)
        EXPR= DEXP(SQPR*X1)
        FX4 =-SQPR*EXPR*CYP*SZR
        HY4 = EXPR/P2*SYP*SZR
        FZ4 =-EXPR*CYP/R1*CZR
        HX4 = FX4*CT1+FZ4*ST1
        HZ4 =-FX4*ST1+FZ4*CT1

        SQPR= DSQRT(1.D0/P2**2+1.D0/R2**2)
        CYP = DCOS(Y/P2)
        SYP = DSIN(Y/P2)
        CZR = DCOS(Z1/R2)
        SZR = DSIN(Z1/R2)
        EXPR= DEXP(SQPR*X1)
        FX5 =-SQPR*EXPR*CYP*SZR
        HY5 = EXPR/P2*SYP*SZR
        FZ5 =-EXPR*CYP/R2*CZR
        HX5 = FX5*CT1+FZ5*ST1
        HZ5 =-FX5*ST1+FZ5*CT1

        SQPR= DSQRT(1.D0/P2**2+1.D0/R3**2)
        CYP = DCOS(Y/P2)
        SYP = DSIN(Y/P2)
        CZR = DCOS(Z1/R3)
        SZR = DSIN(Z1/R3)
        EXPR= DEXP(SQPR*X1)
        FX6 =-EXPR*CYP*(SQPR*Z1*CZR+SZR/R3*(X1+1.D0/SQPR))
        HY6 = EXPR/P2*SYP*(Z1*CZR+X1/R3*SZR/SQPR)
        FZ6 =-EXPR*CYP*(CZR*(1.D0+X1/R3**2/SQPR)-Z1/R3*SZR)
        HX6 = FX6*CT1+FZ6*ST1
        HZ6 =-FX6*ST1+FZ6*CT1
!
!       I=3:
!
        SQPR= DSQRT(1.D0/P3**2+1.D0/R1**2)
        CYP = DCOS(Y/P3)
        SYP = DSIN(Y/P3)
        CZR = DCOS(Z1/R1)
        SZR = DSIN(Z1/R1)
        EXPR= DEXP(SQPR*X1)
        FX7 =-SQPR*EXPR*CYP*SZR
        HY7 = EXPR/P3*SYP*SZR
        FZ7 =-EXPR*CYP/R1*CZR
        HX7 = FX7*CT1+FZ7*ST1
        HZ7 =-FX7*ST1+FZ7*CT1

        SQPR= DSQRT(1.D0/P3**2+1.D0/R2**2)
        CYP = DCOS(Y/P3)
        SYP = DSIN(Y/P3)
        CZR = DCOS(Z1/R2)
        SZR = DSIN(Z1/R2)
        EXPR= DEXP(SQPR*X1)
        FX8 =-SQPR*EXPR*CYP*SZR
        HY8 = EXPR/P3*SYP*SZR
        FZ8 =-EXPR*CYP/R2*CZR
        HX8 = FX8*CT1+FZ8*ST1
        HZ8 =-FX8*ST1+FZ8*CT1

        SQPR= DSQRT(1.D0/P3**2+1.D0/R3**2)
        CYP = DCOS(Y/P3)
        SYP = DSIN(Y/P3)
        CZR = DCOS(Z1/R3)
        SZR = DSIN(Z1/R3)
        EXPR= DEXP(SQPR*X1)
        FX9 =-EXPR*CYP*(SQPR*Z1*CZR+SZR/R3*(X1+1.D0/SQPR))
        HY9 = EXPR/P3*SYP*(Z1*CZR+X1/R3*SZR/SQPR)
        FZ9 =-EXPR*CYP*(CZR*(1.D0+X1/R3**2/SQPR)-Z1/R3*SZR)
        HX9 = FX9*CT1+FZ9*ST1
        HZ9 =-FX9*ST1+FZ9*CT1


       A1=A(1)+A(2)*CPS
       A2=A(3)+A(4)*CPS
       A3=A(5)+A(6)*CPS
       A4=A(7)+A(8)*CPS
       A5=A(9)+A(10)*CPS
       A6=A(11)+A(12)*CPS
       A7=A(13)+A(14)*CPS
       A8=A(15)+A(16)*CPS
       A9=A(17)+A(18)*CPS
       BX=A1*HX1+A2*HX2+A3*HX3+A4*HX4+A5*HX5+A6*HX6+A7*HX7+A8*HX8+A9*HX9
       BY=A1*HY1+A2*HY2+A3*HY3+A4*HY4+A5*HY5+A6*HY6+A7*HY7+A8*HY8+A9*HY9
       BZ=A1*HZ1+A2*HZ2+A3*HZ3+A4*HZ4+A5*HZ5+A6*HZ6+A7*HZ7+A8*HZ8+A9*HZ9


!  MAKE THE TERMS IN THE 2ND SUM ("PARALLEL" SYMMETRY):
!
!       I=1
!
       SQQS= DSQRT(1.D0/Q1**2+1.D0/S1**2)
       CYQ = DCOS(Y/Q1)
       SYQ = DSIN(Y/Q1)
       CZS = DCOS(Z2/S1)
       SZS = DSIN(Z2/S1)
       EXQS= DEXP(SQQS*X2)
       FX1 =-SQQS*EXQS*CYQ*CZS *SPS
       HY1 = EXQS/Q1*SYQ*CZS   *SPS
       FZ1 = EXQS*CYQ/S1*SZS   *SPS
       HX1 = FX1*CT2+FZ1*ST2
       HZ1 =-FX1*ST2+FZ1*CT2

       SQQS= DSQRT(1.D0/Q1**2+1.D0/S2**2)
       CYQ = DCOS(Y/Q1)
       SYQ = DSIN(Y/Q1)
       CZS = DCOS(Z2/S2)
       SZS = DSIN(Z2/S2)
       EXQS= DEXP(SQQS*X2)
       FX2 =-SQQS*EXQS*CYQ*CZS *SPS
       HY2 = EXQS/Q1*SYQ*CZS   *SPS
       FZ2 = EXQS*CYQ/S2*SZS   *SPS
       HX2 = FX2*CT2+FZ2*ST2
       HZ2 =-FX2*ST2+FZ2*CT2

       SQQS= DSQRT(1.D0/Q1**2+1.D0/S3**2)
       CYQ = DCOS(Y/Q1)
       SYQ = DSIN(Y/Q1)
       CZS = DCOS(Z2/S3)
       SZS = DSIN(Z2/S3)
       EXQS= DEXP(SQQS*X2)
       FX3 =-SQQS*EXQS*CYQ*CZS *SPS
       HY3 = EXQS/Q1*SYQ*CZS   *SPS
       FZ3 = EXQS*CYQ/S3*SZS   *SPS
       HX3 = FX3*CT2+FZ3*ST2
       HZ3 =-FX3*ST2+FZ3*CT2
!
!       I=2
!
       SQQS= DSQRT(1.D0/Q2**2+1.D0/S1**2)
       CYQ = DCOS(Y/Q2)
       SYQ = DSIN(Y/Q2)
       CZS = DCOS(Z2/S1)
       SZS = DSIN(Z2/S1)
       EXQS= DEXP(SQQS*X2)
       FX4 =-SQQS*EXQS*CYQ*CZS *SPS
       HY4 = EXQS/Q2*SYQ*CZS   *SPS
       FZ4 = EXQS*CYQ/S1*SZS   *SPS
       HX4 = FX4*CT2+FZ4*ST2
       HZ4 =-FX4*ST2+FZ4*CT2

       SQQS= DSQRT(1.D0/Q2**2+1.D0/S2**2)
       CYQ = DCOS(Y/Q2)
       SYQ = DSIN(Y/Q2)
       CZS = DCOS(Z2/S2)
       SZS = DSIN(Z2/S2)
       EXQS= DEXP(SQQS*X2)
       FX5 =-SQQS*EXQS*CYQ*CZS *SPS
       HY5 = EXQS/Q2*SYQ*CZS   *SPS
       FZ5 = EXQS*CYQ/S2*SZS   *SPS
       HX5 = FX5*CT2+FZ5*ST2
       HZ5 =-FX5*ST2+FZ5*CT2

       SQQS= DSQRT(1.D0/Q2**2+1.D0/S3**2)
       CYQ = DCOS(Y/Q2)
       SYQ = DSIN(Y/Q2)
       CZS = DCOS(Z2/S3)
       SZS = DSIN(Z2/S3)
       EXQS= DEXP(SQQS*X2)
       FX6 =-SQQS*EXQS*CYQ*CZS *SPS
       HY6 = EXQS/Q2*SYQ*CZS   *SPS
       FZ6 = EXQS*CYQ/S3*SZS   *SPS
       HX6 = FX6*CT2+FZ6*ST2
       HZ6 =-FX6*ST2+FZ6*CT2
!
!       I=3
!
       SQQS= DSQRT(1.D0/Q3**2+1.D0/S1**2)
       CYQ = DCOS(Y/Q3)
       SYQ = DSIN(Y/Q3)
       CZS = DCOS(Z2/S1)
       SZS = DSIN(Z2/S1)
       EXQS= DEXP(SQQS*X2)
       FX7 =-SQQS*EXQS*CYQ*CZS *SPS
       HY7 = EXQS/Q3*SYQ*CZS   *SPS
       FZ7 = EXQS*CYQ/S1*SZS   *SPS
       HX7 = FX7*CT2+FZ7*ST2
       HZ7 =-FX7*ST2+FZ7*CT2

       SQQS= DSQRT(1.D0/Q3**2+1.D0/S2**2)
       CYQ = DCOS(Y/Q3)
       SYQ = DSIN(Y/Q3)
       CZS = DCOS(Z2/S2)
       SZS = DSIN(Z2/S2)
       EXQS= DEXP(SQQS*X2)
       FX8 =-SQQS*EXQS*CYQ*CZS *SPS
       HY8 = EXQS/Q3*SYQ*CZS   *SPS
       FZ8 = EXQS*CYQ/S2*SZS   *SPS
       HX8 = FX8*CT2+FZ8*ST2
       HZ8 =-FX8*ST2+FZ8*CT2

       SQQS= DSQRT(1.D0/Q3**2+1.D0/S3**2)
       CYQ = DCOS(Y/Q3)
       SYQ = DSIN(Y/Q3)
       CZS = DCOS(Z2/S3)
       SZS = DSIN(Z2/S3)
       EXQS= DEXP(SQQS*X2)
       FX9 =-SQQS*EXQS*CYQ*CZS *SPS
       HY9 = EXQS/Q3*SYQ*CZS   *SPS
       FZ9 = EXQS*CYQ/S3*SZS   *SPS
       HX9 = FX9*CT2+FZ9*ST2
       HZ9 =-FX9*ST2+FZ9*CT2

       A1=A(19)+A(20)*S2PS
       A2=A(21)+A(22)*S2PS
       A3=A(23)+A(24)*S2PS
       A4=A(25)+A(26)*S2PS
       A5=A(27)+A(28)*S2PS
       A6=A(29)+A(30)*S2PS
       A7=A(31)+A(32)*S2PS
       A8=A(33)+A(34)*S2PS
       A9=A(35)+A(36)*S2PS

       BX=BX+A1*HX1+A2*HX2+A3*HX3+A4*HX4+A5*HX5+A6*HX6+A7*HX7+A8*HX8 &
         +A9*HX9
       BY=BY+A1*HY1+A2*HY2+A3*HY3+A4*HY4+A5*HY5+A6*HY6+A7*HY7+A8*HY8 &
         +A9*HY9
       BZ=BZ+A1*HZ1+A2*HZ2+A3*HZ3+A4*HZ4+A5*HZ5+A6*HZ6+A7*HZ7+A8*HZ8 &
         +A9*HZ9
!
       RETURN
       END
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
      SUBROUTINE DEFORMED_T04 (IOPT,PS,X,Y,Z,BX1,BY1,BZ1,BX2,BY2,BZ2)
!
!   IOPT - TAIL FIELD MODE FLAG:   IOPT=0 - THE TWO TAIL MODES ARE ADDED UP
!                                  IOPT=1 - MODE 1 ONLY
!                                  IOPT=2 - MODE 2 ONLY
!
!   CALCULATES GSM COMPONENTS OF TWO UNIT-AMPLITUDE TAIL FIELD MODES,
!    TAKING INTO ACCOUNT BOTH EFFECTS OF DIPOLE TILT:
!    WARPING IN Y-Z (DONE BY THE S/R WARPED) AND BENDING IN X-Z (DONE BY THIS SUBROUTINE)
!
      IMPLICIT REAL*8 (A-H,O-Z)
      save
      COMMON /RH0_T04/ RH0
      DATA RH2,IEPS /-5.2D0,3/
!
!  RH0,RH1,RH2, AND IEPS CONTROL THE TILT-RELATED DEFORMATION OF THE TAIL FIELD
!
      SPS=DSIN(PS)
! jah, foresys : Result of assignment to CPS is not used
! jah,      CPS=DSQRT(1.D0-SPS**2)
      R2=X**2+Y**2+Z**2
      R=SQRT(R2)
      ZR=Z/R
      RH=RH0+RH2*ZR**2
      DRHDR=-ZR/R*2.D0*RH2*ZR
      DRHDZ= 2.D0*RH2*ZR/R
!
      RRH=R/RH

      F=1.D0/(1.D0+RRH**dble(IEPS))**(1.D0/dble(IEPS))
      DFDR=-RRH**(IEPS-1)*F**(IEPS+1)/RH
      DFDRH=-RRH*DFDR
!
      SPSAS=SPS*F
      CPSAS=DSQRT(1.D0-SPSAS**2)
!
      XAS=X*CPSAS-Z*SPSAS
      ZAS=X*SPSAS+Z*CPSAS
!
      FACPS=SPS/CPSAS*(DFDR+DFDRH*DRHDR)/R
      PSASX=FACPS*X
      PSASY=FACPS*Y
      PSASZ=FACPS*Z+SPS/CPSAS*DFDRH*DRHDZ
!
      DXASDX=CPSAS-ZAS*PSASX
      DXASDY=-ZAS*PSASY
      DXASDZ=-SPSAS-ZAS*PSASZ
      DZASDX=SPSAS+XAS*PSASX
      DZASDY=XAS*PSASY
      DZASDZ=CPSAS+XAS*PSASZ
      FAC1=DXASDZ*DZASDY-DXASDY*DZASDZ
      FAC2=DXASDX*DZASDZ-DXASDZ*DZASDX
      FAC3=DZASDX*DXASDY-DXASDX*DZASDY
!
!     DEFORM:
!
      CALL WARPED_T04(IOPT,PS,XAS,Y,ZAS,BXAS1,BYAS1,BZAS1,BXAS2,BYAS2, &
           BZAS2)
!
      BX1=BXAS1*DZASDZ-BZAS1*DXASDZ +BYAS1*FAC1
      BY1=BYAS1*FAC2
      BZ1=BZAS1*DXASDX-BXAS1*DZASDX +BYAS1*FAC3

      BX2=BXAS2*DZASDZ-BZAS2*DXASDZ +BYAS2*FAC1
      BY2=BYAS2*FAC2
      BZ2=BZAS2*DXASDX-BXAS2*DZASDX +BYAS2*FAC3

      RETURN
      END
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
      SUBROUTINE WARPED_T04 (IOPT,PS,X,Y,Z,BX1,BY1,BZ1,BX2,BY2,BZ2)
!
!   CALCULATES GSM COMPONENTS OF THE WARPED FIELD FOR TWO TAIL UNIT MODES.
!   THE WARPING DEFORMATION IS IMPOSED ON THE UNWARPED FIELD, COMPUTED
!   BY THE S/R "UNWARPED".  THE WARPING PARAMETERS WERE TAKEN FROM THE
!   RESULTS OF GEOTAIL OBSERVATIONS (TSYGANENKO ET AL. [1998]).
!   NB # 6, P.106, OCT 12, 2000.
!
!   IOPT - TAIL FIELD MODE FLAG:   IOPT=0 - THE TWO TAIL MODES ARE ADDED UP
!                                  IOPT=1 - MODE 1 ONLY
!                                  IOPT=2 - MODE 2 ONLY
!
      IMPLICIT REAL*8 (A-H,O-Z)
      save
!
      COMMON /G/ G
      DGDX=0.D0
      XL=20.D0
      DXLDX=0.D0

      SPS=DSIN(PS)
      RHO2=Y**2+Z**2
      RHO=DSQRT(RHO2)

      IF (Y.EQ.0.D0.AND.Z.EQ.0.D0) THEN
       PHI=0.D0
       CPHI=1.D0
       SPHI=0.D0
      ELSE
       PHI=DATAN2(Z,Y)
       CPHI=Y/RHO
       SPHI=Z/RHO
      ENDIF

      RR4L4=RHO/(RHO2**2+XL**4)

      F=PHI+G*RHO2*RR4L4*CPHI*SPS
      DFDPHI=1.D0-G*RHO2*RR4L4*SPHI*SPS
      DFDRHO=G*RR4L4**2*(3.D0*XL**4-RHO2**2)*CPHI*SPS
      DFDX=RR4L4*CPHI*SPS*(DGDX*RHO2-G*RHO*RR4L4*4.D0*XL**3*DXLDX)

      CF=DCOS(F)
      SF=DSIN(F)
      YAS=RHO*CF
      ZAS=RHO*SF

      CALL UNWARPED_T04 (IOPT,X,YAS,ZAS,BX_AS1,BY_AS1,BZ_AS1, &
        BX_AS2,BY_AS2,BZ_AS2)

      BRHO_AS =  BY_AS1*CF+BZ_AS1*SF      !   DEFORM THE 1ST MODE
      BPHI_AS = -BY_AS1*SF+BZ_AS1*CF

      BRHO_S = BRHO_AS*DFDPHI
      BPHI_S = BPHI_AS-RHO*(BX_AS1*DFDX+BRHO_AS*DFDRHO)
      BX1    = BX_AS1*DFDPHI

      BY1    = BRHO_S*CPHI-BPHI_S*SPHI
      BZ1    = BRHO_S*SPHI+BPHI_S*CPHI    !   DONE

      BRHO_AS =  BY_AS2*CF+BZ_AS2*SF      !   DEFORM THE 2ND MODE
      BPHI_AS = -BY_AS2*SF+BZ_AS2*CF

      BRHO_S = BRHO_AS*DFDPHI
      BPHI_S = BPHI_AS-RHO*(BX_AS2*DFDX+BRHO_AS*DFDRHO)
      BX2    = BX_AS2*DFDPHI

      BY2    = BRHO_S*CPHI-BPHI_S*SPHI
      BZ2    = BRHO_S*SPHI+BPHI_S*CPHI    !   DONE

      RETURN
      END
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
       SUBROUTINE UNWARPED_T04 (IOPT,X,Y,Z,BX1,BY1,BZ1,BX2,BY2,BZ2)

!   IOPT - TAIL FIELD MODE FLAG:   IOPT=0 - THE TWO TAIL MODES ARE ADDED UP
!                                  IOPT=1 - MODE 1 ONLY
!                                  IOPT=2 - MODE 2 ONLY
!
!    CALCULATES GSM COMPONENTS OF THE SHIELDED FIELD OF TWO TAIL MODES WITH UNIT
!    AMPLITUDES,  WITHOUT ANY WARPING OR BENDING.  NONLINEAR PARAMETERS OF THE MODES
!    ARE FORWARDED HERE VIA A COMMON BLOCK /TAIL/.
!
      IMPLICIT REAL*8 (A-H,O-Z)
      save
!
      DIMENSION A1(60),A2(60)  !   TAIL SHIELDING FIELD PARAMETERS FOR THE MODES #1 & #2

      COMMON /TAIL/ DXSHIFT1,DXSHIFT2,D0,DELTADY  ! ATTENTION:  HERE D0 & DELTADY ARE INCLUDED IN /TAIL/
!                                                                  AND EXCLUDED FROM DATA
      DATA DELTADX1,ALPHA1,XSHIFT1 &
        /1.D0,1.1D0,6.D0/
      DATA DELTADX2,ALPHA2,XSHIFT2 &
        /0.D0,.25D0,4.D0/

      DATA A1/-25.45869857d0,57.35899080d0,317.5501869d0,-2.626756717d0, &
      -93.38053698d0,-199.6467926d0,-858.8129729d0,34.09192395d0,845.4214929d0, &
      -29.07463068d0,47.10678547d0,-128.9797943d0,-781.7512093d0,6.165038619d0, &
      167.8905046d0,492.0680410d0,1654.724031d0,-46.77337920d0,-1635.922669d0, &
      40.86186772d0,-.1349775602d0,-.9661991179d-01,-.1662302354d0, &
      .002810467517d0,.2487355077d0,.1025565237d0,-14.41750229d0,-.8185333989d0, &
      11.07693629d0,.7569503173d0,-9.655264745d0,112.2446542d0,777.5948964d0, &
      -5.745008536d0,-83.03921993d0,-490.2278695d0,-1155.004209d0,39.08023320d0, &
      1172.780574d0,-39.44349797d0,-14.07211198d0,-40.41201127d0,-313.2277343d0, &
      2.203920979d0,8.232835341d0,197.7065115d0,391.2733948d0,-18.57424451d0, &
      -437.2779053d0,23.04976898d0,11.75673963d0,13.60497313d0,4.691927060d0, &
      18.20923547d0,27.59044809d0,6.677425469d0,1.398283308d0,2.839005878d0, &
      31.24817706d0,24.53577264d0/

      DATA A2/-287187.1962d0,4970.499233d0,410490.1952d0,-1347.839052d0, &
      -386370.3240d0,3317.983750d0,-143462.3895d0,5706.513767d0,171176.2904d0, &
      250.8882750d0,-506570.8891d0,5733.592632d0,397975.5842d0,9771.762168d0, &
      -941834.2436d0,7990.975260d0,54313.10318d0,447.5388060d0,528046.3449d0, &
      12751.04453d0,-21920.98301d0,-21.05075617d0,31971.07875d0,3012.641612d0, &
      -301822.9103d0,-3601.107387d0,1797.577552d0,-6.315855803d0,142578.8406d0, &
      13161.93640d0,804184.8410d0,-14168.99698d0,-851926.6360d0,-1890.885671d0, &
      972475.6869d0,-8571.862853d0,26432.49197d0,-2554.752298d0,-482308.3431d0, &
      -4391.473324d0,105155.9160d0,-1134.622050d0,-74353.53091d0,-5382.670711d0, &
      695055.0788d0,-916.3365144d0,-12111.06667d0,67.20923358d0,-367200.9285d0, &
      -21414.14421d0,14.75567902d0,20.75638190d0,59.78601609d0,16.86431444d0, &
      32.58482365d0,23.69472951d0,17.24977936d0,13.64902647d0,68.40989058d0, &
      11.67828167d0/

      DATA XM1,XM2/2*-12.D0/

      IF (IOPT.EQ.2) GOTO 1

      XSC1=(X-XSHIFT1-DXSHIFT1)*ALPHA1-XM1*(ALPHA1-1.D0)
      YSC1=Y*ALPHA1
      ZSC1=Z*ALPHA1
      D0SC1=D0*ALPHA1   ! HERE WE USE A SINGLE VALUE D0 OF THE THICKNESS FOR BOTH MODES

      CALL TAILDISK_T04(D0SC1,DELTADX1,DELTADY,XSC1,YSC1,ZSC1,FX1,FY1, &
           FZ1)
      CALL SHLCAR5X5_T04(A1,X,Y,Z,DXSHIFT1,HX1,HY1,HZ1)

      BX1=FX1+HX1
      BY1=FY1+HY1
      BZ1=FZ1+HZ1

      IF (IOPT.EQ.1) THEN
        BX2=0.D0
        BY2=0.D0
        BZ2=0.D0
        RETURN
      ENDIF

 1    XSC2=(X-XSHIFT2-DXSHIFT2)*ALPHA2-XM2*(ALPHA2-1.D0)
      YSC2=Y*ALPHA2
      ZSC2=Z*ALPHA2
      D0SC2=D0*ALPHA2   ! HERE WE USE A SINGLE VALUE D0 OF THE THICKNESS FOR BOTH MODES

      CALL TAILDISK_T04(D0SC2,DELTADX2,DELTADY,XSC2,YSC2,ZSC2,FX2,FY2, &
           FZ2)
      CALL SHLCAR5X5_T04(A2,X,Y,Z,DXSHIFT2,HX2,HY2,HZ2)

      BX2=FX2+HX2
      BY2=FY2+HY2
      BZ2=FZ2+HZ2

      IF (IOPT.EQ.2) THEN
        BX1=0.D0
        BY1=0.D0
        BZ1=0.D0
        RETURN
      ENDIF

      RETURN
      END
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
      SUBROUTINE TAILDISK_T04(D0,DELTADX,DELTADY,X,Y,Z,BX,BY,BZ)
!
!      THIS SUBROUTINE COMPUTES THE COMPONENTS OF THE TAIL CURRENT FIELD,
!       SIMILAR TO THAT DESCRIBED BY TSYGANENKO AND PEREDO (1994).  THE
!        DIFFERENCE IS THAT NOW WE USE SPACEWARPING, AS DESCRIBED IN OUR
!         PAPER ON MODELING BIRKELAND CURRENTS (TSYGANENKO AND STERN, 1996)
!          INSTEAD OF SHEARING IT IN THE SPIRIT OF T89 TAIL MODEL.
!
      IMPLICIT REAL*8 (A-H,O-Z)
!
      DIMENSION F(5),B(5),C(5)
      save
!
      DATA F /-71.09346626D0,-1014.308601D0,-1272.939359D0, &
              -3224.935936D0,-44546.86232D0/
      DATA B /10.90101242D0,12.68393898D0,13.51791954D0,14.86775017D0, &
                15.12306404D0/
      DATA C /.7954069972D0,.6716601849D0,1.174866319D0,2.565249920D0, &
                10.01986790D0/
!
      RHO=DSQRT(X**2+Y**2)
      DRHODX=X/RHO
      DRHODY=Y/RHO

      DEX=DEXP(X/7.D0)
      D=D0+DELTADY*(Y/20.D0)**2  +DELTADX*DEX !   THE LAST TERM (INTRODUCED 10/11/2000) MAKES THE SHEET
      DDDY=DELTADY*Y*0.005D0                  !   THICKEN SUNWARD, TO AVOID PROBLEMS IN THE SUBSOLAR REGION
      DDDX=DELTADX/7.D0*DEX
!
      DZETA=DSQRT(Z**2+D**2)  !  THIS IS THE SAME SIMPLE WAY TO SPREAD
!                                        OUT THE SHEET, AS THAT USED IN T89
      DDZETADX=D*DDDX/DZETA
      DDZETADY=D*DDDY/DZETA
      DDZETADZ=Z/DZETA

!
      DBX=0.D0
      DBY=0.D0
      DBZ=0.D0
!
      DO 1 I=1,5
!
      BI=B(I)
      CI=C(I)
!
      S1=DSQRT((RHO+BI)**2+(DZETA+CI)**2)
      S2=DSQRT((RHO-BI)**2+(DZETA+CI)**2)

      DS1DRHO=(RHO+BI)/S1
      DS2DRHO=(RHO-BI)/S2
      DS1DDZ=(DZETA+CI)/S1
      DS2DDZ=(DZETA+CI)/S2
!
      DS1DX=DS1DRHO*DRHODX  +DS1DDZ*DDZETADX
      DS1DY=DS1DRHO*DRHODY  +   DS1DDZ*DDZETADY
      DS1DZ=                      DS1DDZ*DDZETADZ
!
      DS2DX=DS2DRHO*DRHODX  +DS2DDZ*DDZETADX
      DS2DY=DS2DRHO*DRHODY  +   DS2DDZ*DDZETADY
      DS2DZ=                    DS2DDZ*DDZETADZ
!
      S1TS2=S1*S2
      S1PS2=S1+S2
      S1PS2SQ=S1PS2**2

      FAC1=DSQRT(S1PS2SQ-(2.D0*BI)**2)
      AS=FAC1/(S1TS2*S1PS2SQ)
      DASDS1=(1.D0/(FAC1*S2)-AS/S1PS2*(S2*S2+S1*(3.D0*S1+4.D0*S2))) &
                /(S1*S1PS2)
      DASDS2=(1.D0/(FAC1*S1)-AS/S1PS2*(S1*S1+S2*(3.D0*S2+4.D0*S1))) &
                /(S2*S1PS2)
!
      DASDX=DASDS1*DS1DX+DASDS2*DS2DX
      DASDY=DASDS1*DS1DY+DASDS2*DS2DY
      DASDZ=DASDS1*DS1DZ+DASDS2*DS2DZ
!
      DBX=DBX-F(I)*X*DASDZ
      DBY=DBY-F(I)*Y*DASDZ
  1   DBZ=DBZ+F(I)*(2.D0*AS+X*DASDX+Y*DASDY)

      BX=DBX
      BY=DBY
      BZ=DBZ

      RETURN
      END
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
! THIS CODE RETURNS THE SHIELDING FIELD REPRESENTED BY  5x5=25 "CARTESIAN"
!    HARMONICS
!
         SUBROUTINE  SHLCAR5X5_T04(A,X,Y,Z,DSHIFT,HX,HY,HZ)
!
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  The NLIN coefficients are the amplitudes of the "cartesian"
!    harmonics (A(1)-A(NLIN).
!  The NNP nonlinear parameters (A(NLIN+1)-A(NTOT) are the scales Pi and Ri
!   entering the arguments of exponents, sines, and cosines in each of the
!   NLIN "Cartesian" harmonics
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!
         IMPLICIT  REAL * 8  (A - H, O - Z)
!
         DIMENSION A(60)
      save
!
         DHX=0.D0
         DHY=0.D0
         DHZ=0.D0

         L=0
!
         DO 2 I=1,5
         RP=1.D0/A(50+I)
         CYPI=DCOS(Y*RP)
         SYPI=DSIN(Y*RP)
!
         DO 2 K=1,5
         RR=1.D0/A(55+K)
         SZRK=DSIN(Z*RR)
         CZRK=DCOS(Z*RR)
         SQPR=DSQRT(RP**2+RR**2)
         EPR=DEXP(X*SQPR)
!
         DBX=-SQPR*EPR*CYPI*SZRK
         DBY= RP*EPR*SYPI*SZRK
         DBZ=-RR*EPR*CYPI*CZRK

         L=L+2
         COEF=A(L-1)+A(L)*DSHIFT

         DHX=DHX+COEF*DBX
         DHY=DHY+COEF*DBY
         DHZ=DHZ+COEF*DBZ
!
  2      CONTINUE

         HX=DHX
         HY=DHY
         HZ=DHZ
!
      RETURN
      END
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
      SUBROUTINE BIRK_TOT_T04 (IOPB,PS,X,Y,Z,BX11,BY11,BZ11,BX12,BY12, &
           BZ12, &
                                BX21,BY21,BZ21,BX22,BY22,BZ22)
!
!      IOPB -  BIRKELAND FIELD MODE FLAG:
!         IOPB=0 - ALL COMPONENTS
!         IOPB=1 - REGION 1, MODES 1 & 2
!         IOPB=2 - REGION 2, MODES 1 & 2
!
      IMPLICIT REAL*8 (A-H,O-Z)
      save
      DIMENSION SH11(86),SH12(86),SH21(86),SH22(86)
      COMMON /BIRKPAR/ XKAPPA1,XKAPPA2   !  INPUT PARAMETERS, SPECIFIED FROM A MAIN PROGRAM
      COMMON /DPHI_B_RHO0/ DPHI,B,RHO_0,XKAPPA ! PARAMETERS, CONTROL DAY-NIGHT ASYMMETRY OF F.A.C.

      DATA SH11/46488.84663d0,-15541.95244d0,-23210.09824d0,-32625.03856d0, &
      -109894.4551d0,-71415.32808d0,58168.94612d0,55564.87578d0,-22890.60626d0, &
      -6056.763968d0,5091.368100d0,239.7001538d0,-13899.49253d0,4648.016991d0, &
      6971.310672d0,9699.351891d0,32633.34599d0,21028.48811d0,-17395.96190d0, &
      -16461.11037d0,7447.621471d0,2528.844345d0,-1934.094784d0,-588.3108359d0, &
      -32588.88216d0,10894.11453d0,16238.25044d0,22925.60557d0,77251.11274d0, &
      50375.97787d0,-40763.78048d0,-39088.60660d0,15546.53559d0,3559.617561d0, &
      -3187.730438d0,309.1487975d0,88.22153914d0,-243.0721938d0,-63.63543051d0, &
      191.1109142d0,69.94451996d0,-187.9539415d0,-49.89923833d0,104.0902848d0, &
      -120.2459738d0,253.5572433d0,89.25456949d0,-205.6516252d0,-44.93654156d0, &
      124.7026309d0,32.53005523d0,-98.85321751d0,-36.51904756d0,98.88241690d0, &
      24.88493459d0,-55.04058524d0,61.14493565d0,-128.4224895d0,-45.35023460d0, &
      105.0548704d0,-43.66748755d0,119.3284161d0,31.38442798d0,-92.87946767d0, &
      -33.52716686d0,89.98992001d0,25.87341323d0,-48.86305045d0,59.69362881d0, &
      -126.5353789d0,-44.39474251d0,101.5196856d0,59.41537992d0,41.18892281d0, &
      80.86101200d0,3.066809418d0,7.893523804d0,30.56212082d0,10.36861082d0, &
      8.222335945d0,19.97575641d0,2.050148531d0,4.992657093d0,2.300564232d0, &
      .2256245602d0,-.05841594319d0/

      DATA SH12/210260.4816d0,-1443587.401d0,-1468919.281d0,281939.2993d0, &
      -1131124.839d0,729331.7943d0,2573541.307d0,304616.7457d0,468887.5847d0, &
      181554.7517d0,-1300722.650d0,-257012.8601d0,645888.8041d0,-2048126.412d0, &
      -2529093.041d0,571093.7972d0,-2115508.353d0,1122035.951d0,4489168.802d0, &
      75234.22743d0,823905.6909d0,147926.6121d0,-2276322.876d0,-155528.5992d0, &
      -858076.2979d0,3474422.388d0,3986279.931d0,-834613.9747d0,3250625.781d0, &
      -1818680.377d0,-7040468.986d0,-414359.6073d0,-1295117.666d0,-346320.6487d0, &
      3565527.409d0,430091.9496d0,-.1565573462d0,7.377619826d0,.4115646037d0, &
      -6.146078880d0,3.808028815d0,-.5232034932d0,1.454841807d0,-12.32274869d0, &
      -4.466974237d0,-2.941184626d0,-.6172620658d0,12.64613490d0,1.494922012d0, &
      -21.35489898d0,-1.652256960d0,16.81799898d0,-1.404079922d0,-24.09369677d0, &
      -10.99900839d0,45.94237820d0,2.248579894d0,31.91234041d0,7.575026816d0, &
      -45.80833339d0,-1.507664976d0,14.60016998d0,1.348516288d0,-11.05980247d0, &
      -5.402866968d0,31.69094514d0,12.28261196d0,-37.55354174d0,4.155626879d0, &
      -33.70159657d0,-8.437907434d0,36.22672602d0,145.0262164d0,70.73187036d0, &
      85.51110098d0,21.47490989d0,24.34554406d0,31.34405345d0,4.655207476d0, &
      5.747889264d0,7.802304187d0,1.844169801d0,4.867254550d0,2.941393119d0, &
      .1379899178d0,.06607020029d0/

      DATA SH21/162294.6224d0,503885.1125d0,-27057.67122d0,-531450.1339d0, &
      84747.05678d0,-237142.1712d0,84133.61490d0,259530.0402d0,69196.05160d0, &
      -189093.5264d0,-19278.55134d0,195724.5034d0,-263082.6367d0,-818899.6923d0, &
      43061.10073d0,863506.6932d0,-139707.9428d0,389984.8850d0,-135167.5555d0, &
      -426286.9206d0,-109504.0387d0,295258.3531d0,30415.07087d0,-305502.9405d0, &
      100785.3400d0,315010.9567d0,-15999.50673d0,-332052.2548d0,54964.34639d0, &
      -152808.3750d0,51024.67566d0,166720.0603d0,40389.67945d0,-106257.7272d0, &
      -11126.14442d0,109876.2047d0,2.978695024d0,558.6019011d0,2.685592939d0, &
      -338.0004730d0,-81.99724090d0,-444.1102659d0,89.44617716d0,212.0849592d0, &
      -32.58562625d0,-982.7336105d0,-35.10860935d0,567.8931751d0,-1.917212423d0, &
      -260.2023543d0,-1.023821735d0,157.5533477d0,23.00200055d0,232.0603673d0, &
      -36.79100036d0,-111.9110936d0,18.05429984d0,447.0481000d0,15.10187415d0, &
      -258.7297813d0,-1.032340149d0,-298.6402478d0,-1.676201415d0,180.5856487d0, &
      64.52313024d0,209.0160857d0,-53.85574010d0,-98.52164290d0,14.35891214d0, &
      536.7666279d0,20.09318806d0,-309.7349530d0,58.54144539d0,67.45226850d0, &
      97.92374406d0,4.752449760d0,10.46824379d0,32.91856110d0,12.05124381d0, &
      9.962933904d0,15.91258637d0,1.804233877d0,6.578149088d0,2.515223491d0, &
      .1930034238d0,-.02261109942d0/

      DATA SH22/-131287.8986d0,-631927.6885d0,-318797.4173d0,616785.8782d0, &
      -50027.36189d0,863099.9833d0,47680.20240d0,-1053367.944d0,-501120.3811d0, &
      -174400.9476d0,222328.6873d0,333551.7374d0,-389338.7841d0,-1995527.467d0, &
      -982971.3024d0,1960434.268d0,297239.7137d0,2676525.168d0,-147113.4775d0, &
      -3358059.979d0,-2106979.191d0,-462827.1322d0,1017607.960d0,1039018.475d0, &
      520266.9296d0,2627427.473d0,1301981.763d0,-2577171.706d0,-238071.9956d0, &
      -3539781.111d0,94628.16420d0,4411304.724d0,2598205.733d0,637504.9351d0, &
      -1234794.298d0,-1372562.403d0,-2.646186796d0,-31.10055575d0,2.295799273d0, &
      19.20203279d0,30.01931202d0,-302.1028550d0,-14.78310655d0,162.1561899d0, &
      .4943938056d0,176.8089129d0,-.2444921680d0,-100.6148929d0,9.172262228d0, &
      137.4303440d0,-8.451613443d0,-84.20684224d0,-167.3354083d0,1321.830393d0, &
      76.89928813d0,-705.7586223d0,18.28186732d0,-770.1665162d0,-9.084224422d0, &
      436.3368157d0,-6.374255638d0,-107.2730177d0,6.080451222d0,65.53843753d0, &
      143.2872994d0,-1028.009017d0,-64.22739330d0,547.8536586d0,-20.58928632d0, &
      597.3893669d0,10.17964133d0,-337.7800252d0,159.3532209d0,76.34445954d0, &
      84.74398828d0,12.76722651d0,27.63870691d0,32.69873634d0,5.145153451d0, &
      6.310949163d0,6.996159733d0,1.971629939d0,4.436299219d0,2.904964304d0, &
      .1486276863d0,.06859991529d0/

      XKAPPA=XKAPPA1        !  FORWARDED IN BIRK_1N2
      X_SC=XKAPPA1-1.1D0    !  FORWARDED IN BIRK_SHL

      IF (IOPB.EQ.0.OR.IOPB.EQ.1) THEN

      CALL BIRK_1N2_T04 (1,1,PS,X,Y,Z,FX11,FY11,FZ11)           !  REGION 1, MODE 1
      CALL BIRK_SHL_T04 (SH11,PS,X_SC,X,Y,Z,HX11,HY11,HZ11)
      BX11=FX11+HX11
      BY11=FY11+HY11
      BZ11=FZ11+HZ11

      CALL BIRK_1N2_T04 (1,2,PS,X,Y,Z,FX12,FY12,FZ12)           !  REGION 1, MODE 2
      CALL BIRK_SHL_T04 (SH12,PS,X_SC,X,Y,Z,HX12,HY12,HZ12)
      BX12=FX12+HX12
      BY12=FY12+HY12
      BZ12=FZ12+HZ12

      ENDIF

      XKAPPA=XKAPPA2        !  FORWARDED IN BIRK_1N2
      X_SC=XKAPPA2-1.0D0    !  FORWARDED IN BIRK_SHL

      IF (IOPB.EQ.0.OR.IOPB.EQ.2) THEN

      CALL BIRK_1N2_T04 (2,1,PS,X,Y,Z,FX21,FY21,FZ21)           !  REGION 2, MODE 1
      CALL BIRK_SHL_T04 (SH21,PS,X_SC,X,Y,Z,HX21,HY21,HZ21)
      BX21=FX21+HX21
      BY21=FY21+HY21
      BZ21=FZ21+HZ21

      CALL BIRK_1N2_T04 (2,2,PS,X,Y,Z,FX22,FY22,FZ22)           !  REGION 2, MODE 2
      CALL BIRK_SHL_T04 (SH22,PS,X_SC,X,Y,Z,HX22,HY22,HZ22)
      BX22=FX22+HX22
      BY22=FY22+HY22
      BZ22=FZ22+HZ22

      ENDIF

      RETURN
      END
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
      SUBROUTINE BIRK_1N2_T04 (NUMB,MODE,PS,X,Y,Z,BX,BY,BZ)
!
!  CALCULATES COMPONENTS  OF REGION 1/2 FIELD IN SPHERICAL COORDS.  DERIVED FROM THE S/R DIPDEF2C (WHICH
!    DOES THE SAME JOB, BUT INPUT/OUTPUT THERE WAS IN SPHERICAL COORDS, WHILE HERE WE USE CARTESIAN ONES)
!
!   INPUT:  NUMB=1 (2) FOR REGION 1 (2) CURRENTS
!           MODE=1 YIELDS SIMPLE SINUSOIDAL MLT VARIATION, WITH MAXIMUM CURRENT AT DAWN/DUSK MERIDIAN
!     WHILE MODE=2 YIELDS THE SECOND HARMONIC.
!
!
      IMPLICIT REAL*8 (A-H,O-Z)
      save
      DIMENSION A11(31),A12(31),A21(31),A22(31)
      COMMON /MODENUM/ M
      COMMON /DTHETA/ DTHETA

! THESE PARAMETERS CONTROL DAY-NIGHT ASYMMETRY OF F.A.C., AS FOLLOWS:
!  (1) DPHI:   HALF-DIFFERENCE (IN RADIANS) BETWEEN DAY AND NIGHT LATITUDE OF FAC OVAL AT IONOSPHERIC ALTITUDE;
!              TYPICAL VALUE: 0.06
!  (2) B:      AN ASYMMETRY FACTOR AT HIGH-ALTITUDES;  FOR B=0, THE ONLY ASYMMETRY IS THAT FROM DPHI
!              TYPICAL VALUES: 0.35-0.70
!  (3) RHO_0:  A FIXED PARAMETER, DEFINING THE DISTANCE RHO, AT WHICH THE LATITUDE SHIFT GRADUALLY SATURATES AND
!              STOPS INCREASING
!              ITS VALUE WAS ASSUMED FIXED, EQUAL TO 7.0.
!  (4) XKAPPA: AN OVERALL SCALING FACTOR, WHICH CAN BE USED FOR CHANGING THE SIZE OF THE F.A.C. OVAL
!
      COMMON /DPHI_B_RHO0/ DPHI,B,RHO_0,XKAPPA 
! parameters of the tilt-dependent deformation of the untilted F.A.C. field
      DATA BETA,RH,EPS/0.9D0,10.D0,3.D0/ 

      DATA A11/.1618068350d0,-.1797957553d0,2.999642482d0,-.9322708978d0, &
      -.6811059760d0,.2099057262d0,-8.358815746d0,-14.86033550d0,.3838362986d0, &
      -16.30945494d0,4.537022847d0,2.685836007d0,27.97833029d0,6.330871059d0, &
      1.876532361d0,18.95619213d0,.9651528100d0,.4217195118d0,-.08957770020d0, &
      -1.823555887d0,.7457045438d0,-.5785916524d0,-1.010200918d0,.01112389357d0, &
      .09572927448d0,-.3599292276d0,8.713700514d0,.9763932955d0,3.834602998d0, &
      2.492118385d0,.7113544659d0/

      DATA A12/.7058026940d0,-.2845938535d0,5.715471266d0,-2.472820880d0, &
      -.7738802408d0,.3478293930d0,-11.37653694d0,-38.64768867d0,.6932927651d0, &
      -212.4017288d0,4.944204937d0,3.071270411d0,33.05882281d0,7.387533799d0, &
      2.366769108d0,79.22572682d0,.6154290178d0,.5592050551d0,-.1796585105d0, &
      -1.654932210d0,.7309108776d0,-.4926292779d0,-1.130266095d0,-.009613974555d0, &
      .1484586169d0,-.2215347198d0,7.883592948d0,.02768251655d0,2.950280953d0, &
      1.212634762d0,.5567714182d0/

      DATA A21/.1278764024d0,-.2320034273d0,1.805623266d0,-32.37241440d0, &
      -.9931490648d0,.3175085630d0,-2.492465814d0,-16.21600096d0,.2695393416d0, &
      -6.752691265d0,3.971794901d0,14.54477563d0,41.10158386d0,7.912889730d0, &
      1.258297372d0,9.583547721d0,1.014141963d0,.5104134759d0,-.1790430468d0, &
      -1.756358428d0,.7561986717d0,-.6775248254d0,-.04014016420d0,.01446794851d0, &
      .1200521731d0,-.2203584559d0,4.508963850d0,.8221623576d0,1.779933730d0, &
      1.102649543d0,.8867880020d0/

      DATA A22/.4036015198d0,-.3302974212d0,2.827730930d0,-45.44405830d0, &
      -1.611103927d0,.4927112073d0,-.003258457559d0,-49.59014949d0,.3796217108d0, &
      -233.7884098d0,4.312666980d0,18.05051709d0,28.95320323d0,11.09948019d0, &
      .7471649558d0,67.10246193d0,.5667096597d0,.6468519751d0,-.1560665317d0, &
      -1.460805289d0,.7719653528d0,-.6658988668d0,.2515179349d-05, &
      .02426021891d0,.1195003324d0,-.2625739255d0,4.377172556d0,.2421190547d0, &
      2.503482679d0,1.071587299d0,.7247997430d0/

      B=0.5d0
      RHO_0=7.0d0

      M=MODE
      IF (NUMB.EQ.1) THEN
          DPHI=0.055D0
          DTHETA=0.06D0
      ENDIF

      IF (NUMB.EQ.2) THEN
          DPHI=0.030D0
          DTHETA=0.09D0
      ENDIF

      Xsc=X*XKAPPA
      Ysc=Y*XKAPPA
      Zsc=Z*XKAPPA
      RHO=DSQRT(Xsc**2+Zsc**2)

      Rsc=DSQRT(Xsc**2+Ysc**2+Zsc**2)                                 !  SCALED
      RHO2=RHO_0**2

      IF (Xsc.EQ.0.D0.AND.Zsc.EQ.0.D0) THEN
         PHI=0.D0
      ELSE
         PHI=DATAN2(-Zsc,Xsc)  !  FROM CARTESIAN TO CYLINDRICAL (RHO,PHI,Y)
      ENDIF

      SPHIC=DSIN(PHI)
      CPHIC=DCOS(PHI)  !  "C" means "CYLINDRICAL", TO DISTINGUISH FROM SPHERICAL PHI

      BRACK=DPHI+B*RHO2/(RHO2+1.D0)*(RHO**2-1.D0)/(RHO2+RHO**2)
      R1RH=(Rsc-1.D0)/RH
      PSIAS=BETA*PS/(1.D0+R1RH**EPS)**(1.D0/EPS)

      PHIS=PHI-BRACK*DSIN(PHI) -PSIAS
      DPHISPHI=1.D0-BRACK*DCOS(PHI)
      DPHISRHO=-2.D0*B*RHO2*RHO/(RHO2+RHO**2)**2 *DSIN(PHI) &
         +BETA*PS*R1RH**(EPS-1.D0)*RHO/(RH*Rsc* &
         (1.D0+R1RH**EPS)**(1.D0/EPS+1.D0))
      DPHISDY= BETA*PS*R1RH**(EPS-1.D0)*Ysc/(RH*Rsc* &
         (1.D0+R1RH**EPS)**(1.D0/EPS+1.D0))

      SPHICS=DSIN(PHIS)
      CPHICS=DCOS(PHIS)

      XS= RHO*CPHICS
      ZS=-RHO*SPHICS

      IF (NUMB.EQ.1) THEN
        IF (MODE.EQ.1) CALL TWOCONES_T04 (A11,XS,Ysc,ZS,BXS,BYAS,BZS)
        IF (MODE.EQ.2) CALL TWOCONES_T04 (A12,XS,Ysc,ZS,BXS,BYAS,BZS)
      ELSE
        IF (MODE.EQ.1) CALL TWOCONES_T04 (A21,XS,Ysc,ZS,BXS,BYAS,BZS)
        IF (MODE.EQ.2) CALL TWOCONES_T04 (A22,XS,Ysc,ZS,BXS,BYAS,BZS)
      ENDIF

      BRHOAS=BXS*CPHICS-BZS*SPHICS
      BPHIAS=-BXS*SPHICS-BZS*CPHICS

      BRHO_S=BRHOAS*DPHISPHI                             *XKAPPA        ! SCALING
      BPHI_S=(BPHIAS-RHO*(BYAS*DPHISDY+BRHOAS*DPHISRHO)) *XKAPPA
      BY_S=BYAS*DPHISPHI                                 *XKAPPA

      BX=BRHO_S*CPHIC-BPHI_S*SPHIC
      BY=BY_S
      BZ=-BRHO_S*SPHIC-BPHI_S*CPHIC

      RETURN
      END
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
      SUBROUTINE TWOCONES_T04 (A,X,Y,Z,BX,BY,BZ)
!
!   ADDS FIELDS FROM TWO CONES (NORTHERN AND SOUTHERN), WITH A PROPER SYMMETRY OF THE CURRENT AND FIELD,
!     CORRESPONDING TO THE REGION 1 BIRKELAND CURRENTS.
!

      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION A(31)
      save

      CALL ONE_CONE_T04 (A,X,Y,Z,BXN,BYN,BZN)
      CALL ONE_CONE_T04 (A,X,-Y,-Z,BXS,BYS,BZS)
      BX=BXN-BXS
      BY=BYN+BYS
      BZ=BZN+BZS

      RETURN
      END
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
      SUBROUTINE ONE_CONE_T04(A,X,Y,Z,BX,BY,BZ)
!
!  RETURNS FIELD COMPONENTS FOR A DEFORMED CONICAL CURRENT SYSTEM, FITTED TO A BIOSAVART FIELD
!    BY SIM_14.FOR.  HERE ONLY THE NORTHERN CONE IS TAKEN INTO ACCOUNT.
!

      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION A(31)
      save

      COMMON /DTHETA/ DTHETA
      COMMON /MODENUM/ M

      DATA DR,DT/1.D-6,1.D-6/  !   JUST FOR NUMERICAL DIFFERENTIATION

      THETA0=A(31)

      RHO2=X**2+Y**2
      RHO=DSQRT(RHO2)
      R=DSQRT(RHO2+Z**2)
      THETA=DATAN2(RHO,Z)
      PHI=DATAN2(Y,X)
!
!   MAKE THE DEFORMATION OF COORDINATES:
!
       RS=R_S_T04(A,R,THETA)
       THETAS=THETA_S_T04(A,R,THETA)
       PHIS=PHI
!
!   CALCULATE FIELD COMPONENTS AT THE NEW POSITION (ASTERISKED):
!
       CALL FIALCOS_T04 (RS,THETAS,PHIS,BTAST,BFAST,M,THETA0,DTHETA)    !   MODE #M
!
!   NOW TRANSFORM B{R,T,F}_AST BY THE DEFORMATION TENSOR:
!
!      FIRST OF ALL, FIND THE DERIVATIVES:
!
       DRSDR=(R_S_T04(A,R+DR,THETA)-R_S_T04(A,R-DR,THETA))/(2.D0*DR)
       DRSDT=(R_S_T04(A,R,THETA+DT)-R_S_T04(A,R,THETA-DT))/(2.D0*DT)
       DTSDR=(THETA_S_T04(A,R+DR,THETA)- &
            THETA_S_T04(A,R-DR,THETA))/(2.D0*DR)
       DTSDT=(THETA_S_T04(A,R,THETA+DT)- &
            THETA_S_T04(A,R,THETA-DT))/(2.D0*DT)

       STSST=DSIN(THETAS)/DSIN(THETA)
       RSR=RS/R

       BR     =-RSR/R*STSST*BTAST*DRSDT
       BTHETA = RSR*STSST*BTAST*DRSDR
       BPHI   = RSR*BFAST*(DRSDR*DTSDT-DRSDT*DTSDR)

       S=RHO/R
       C=Z/R
       SF=Y/RHO
       CF=X/RHO

       BE=BR*S+BTHETA*C

       BX=A(1)*(BE*CF-BPHI*SF)
       BY=A(1)*(BE*SF+BPHI*CF)
       BZ=A(1)*(BR*C-BTHETA*S)

       RETURN
       END
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

      DOUBLE PRECISION FUNCTION R_S_T04(A,R,THETA)
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION A(31)
      save
!
      R_S_T04=R+A(2)/R+A(3)*R/DSQRT(R**2+A(11)**2)+A(4)*R/ &
           (R**2+A(12)**2) &
      +(A(5)+A(6)/R+A(7)*R/DSQRT(R**2+A(13)**2)+A(8)*R/(R**2+A(14)**2))* &
       DCOS(THETA) &
      +(A(9)*R/DSQRT(R**2+A(15)**2)+A(10)*R/(R**2+A(16)**2)**2) &
       *DCOS(2.D0*THETA)
!
      RETURN
      END
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
      DOUBLE PRECISION FUNCTION THETA_S_T04(A,R,THETA)
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION A(31)
      save
!
      THETA_S_T04=THETA+(A(17)+A(18)/R+A(19)/R**2 &
                      +A(20)*R/DSQRT(R**2+A(27)**2))*DSIN(THETA) &
       +(A(21)+A(22)*R/DSQRT(R**2+A(28)**2) &
                      +A(23)*R/(R**2+A(29)**2))*DSIN(2.D0*THETA) &
       +(A(24)+A(25)/R+A(26)*R/(R**2+A(30)**2))*DSIN(3.D0*THETA)
!
      RETURN
      END
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
      SUBROUTINE FIALCOS_T04(R,THETA,PHI,BTHETA,BPHI,N,THETA0,DT)
!
!  CONICAL MODEL OF BIRKELAND CURRENT FIELD; BASED ON THE OLD S/R FIALCO (OF 1990-91)

!  BTN, AND BPN ARE THE ARRAYS OF BTHETA AND BPHI (BTN(i), BPN(i) CORRESPOND TO i-th MODE).
!   ONLY FIRST  N  MODE AMPLITUDES ARE COMPUTED (N<=10).
!    THETA0 IS THE ANGULAR HALF-WIDTH OF THE CONE, DT IS THE ANGULAR H.-W. OF THE CURRENT LAYER

!   NOTE:  BR=0  (BECAUSE ONLY RADIAL CURRENTS ARE PRESENT IN THIS MODEL)
!
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION  BTN(10),BPN(10),CCOS(10),SSIN(10)
      save

      SINTE=DSIN(THETA)
      RO=R*SINTE
      COSTE=DCOS(THETA)
      SINFI=DSIN(PHI)
      COSFI=DCOS(PHI)
      TG=SINTE/(1.D0+COSTE)   !        TAN(THETA/2)
      CTG=SINTE/(1.D0-COSTE)  !        CTG(THETA/2)
!
!
      TETANP=THETA0+DT
      TETANM=THETA0-DT
      IF(THETA.LT.TETANM) GOTO 1
      TGP=DTAN(TETANP*0.5D0)
      TGM=DTAN(TETANM*0.5D0)
      TGM2=TGM*TGM
      TGP2=TGP*TGP
  1   CONTINUE

      COSM1=1.D0
      SINM1=0.D0
      TM=1.D0
      TGM2M=1.D0
      TGP2M=1.D0

      DO 2 M=1,N
      TM=TM*TG
      CCOS(M)=COSM1*COSFI-SINM1*SINFI
      SSIN(M)=SINM1*COSFI+COSM1*SINFI
      COSM1=CCOS(M)
      SINM1=SSIN(M)
      IF(THETA.LT.TETANM) THEN
      T=TM
      DTT=0.5D0*dble(M)*TM*(TG+CTG)
! jah, foresys : Result of assignment to DTT0 is not used
! jah,      DTT0=0.D0
      ELSE IF(THETA.LT.TETANP) THEN
      TGM2M=TGM2M*TGM2
      FC=1.D0/(TGP-TGM)
      FC1=1.D0/dble(2*M+1)
      TGM2M1=TGM2M*TGM
      TG21=1.D0+TG*TG
      T=FC*(TM*(TGP-TG)+FC1*(TM*TG-TGM2M1/TM))
      DTT=0.5D0*dble(M)*FC*TG21*(TM/TG*(TGP-TG)-FC1*(TM-TGM2M1/(TM*TG)))
! jah, foresys : Result of assignment to DTT0 is not used
! jah,      DTT0=0.5D0*FC*((TGP+TGM)*(TM*TG-FC1*(TM*TG-TGM2M1/TM))+
! jah,     * TM*(1.D0-TGP*TGM)-(1.D0+TGM2)*TGM2M/TM)
      ELSE
      TGP2M=TGP2M*TGP2
      TGM2M=TGM2M*TGM2
      FC=1.D0/(TGP-TGM)
      FC1=1.D0/dble(2*M+1)
      T=FC*FC1*(TGP2M*TGP-TGM2M*TGM)/TM
      DTT=-T*dble(M)*0.5D0*(TG+CTG)
      ENDIF

      BTN(M)=dble(M)*T*CCOS(M)/RO
  2   BPN(M)=-DTT*SSIN(M)/R

      BTHETA=BTN(N)*800.d0
      BPHI  =BPN(N)*800.d0

      RETURN
      END
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
         SUBROUTINE BIRK_SHL_T04 (A,PS,X_SC,X,Y,Z,BX,BY,BZ)
!
         IMPLICIT  REAL * 8  (A - H, O - Z)
         DIMENSION A(86)
      save
!
         CPS=DCOS(PS)
         SPS=DSIN(PS)

         S3PS=2.D0*CPS
!
         PST1=PS*A(85)
         PST2=PS*A(86)

         ST1=DSIN(PST1)
         CT1=DCOS(PST1)
         ST2=DSIN(PST2)
         CT2=DCOS(PST2)

         X1=X*CT1-Z*ST1
         Z1=X*ST1+Z*CT1
         X2=X*CT2-Z*ST2
         Z2=X*ST2+Z*CT2
!
         L=0
         GX=0.D0
         GY=0.D0
         GZ=0.D0
!
         DO 1 M=1,2     !    M=1 IS FOR THE 1ST SUM ("PERP." SYMMETRY)
!                          AND M=2 IS FOR THE SECOND SUM ("PARALL." SYMMETRY)
             DO 2 I=1,3
                  P=A(72+I)
                  Q=A(78+I)
                  CYPI=DCOS(Y/P)
                  CYQI=DCOS(Y/Q)
                  SYPI=DSIN(Y/P)
                  SYQI=DSIN(Y/Q)
!
                DO 3 K=1,3
                   R=A(75+K)
                   S=A(81+K)
                   SZRK=DSIN(Z1/R)
                   CZSK=DCOS(Z2/S)
                   CZRK=DCOS(Z1/R)
                   SZSK=DSIN(Z2/S)
                     SQPR=DSQRT(1.D0/P**2+1.D0/R**2)
                     SQQS=DSQRT(1.D0/Q**2+1.D0/S**2)
                        EPR=DEXP(X1*SQPR)
                        EQS=DEXP(X2*SQQS)
!
                  DO 4 N=1,2  ! N=1 IS FOR THE FIRST PART OF EACH COEFFICIENT
!                                AND N=2 IS FOR THE SECOND ONE

                    DO 5 NN=1,2 !   NN = 1,2 FURTHER SPLITS THE COEFFICIENTS INTO 2 PARTS,
!                                         TO TAKE INTO ACCOUNT THE SCALE FACTOR DEPENDENCE

                    IF (M.EQ.1) THEN
                         FX=-SQPR*EPR*CYPI*SZRK
                         FY=EPR*SYPI*SZRK/P
                         FZ=-EPR*CYPI*CZRK/R
                       IF (N.EQ.1) THEN
                         IF (NN.EQ.1) THEN
                          HX=FX
                          HY=FY
                          HZ=FZ
                         ELSE
                          HX=FX*X_SC
                          HY=FY*X_SC
                          HZ=FZ*X_SC
                         ENDIF
                       ELSE
                         IF (NN.EQ.1) THEN
                          HX=FX*CPS
                          HY=FY*CPS
                          HZ=FZ*CPS
                         ELSE
                          HX=FX*CPS*X_SC
                          HY=FY*CPS*X_SC
                          HZ=FZ*CPS*X_SC
                         ENDIF
                       ENDIF

                     ELSE                            !   M.EQ.2
                         FX=-SPS*SQQS*EQS*CYQI*CZSK
                         FY=SPS/Q*EQS*SYQI*CZSK
                         FZ=SPS/S*EQS*CYQI*SZSK
                       IF (N.EQ.1) THEN
                        IF (NN.EQ.1) THEN
                          HX=FX
                          HY=FY
                          HZ=FZ
                        ELSE
                          HX=FX*X_SC
                          HY=FY*X_SC
                          HZ=FZ*X_SC
                        ENDIF
                       ELSE
                        IF (NN.EQ.1) THEN
                         HX=FX*S3PS
                         HY=FY*S3PS
                         HZ=FZ*S3PS
                        ELSE
                         HX=FX*S3PS*X_SC
                         HY=FY*S3PS*X_SC
                         HZ=FZ*S3PS*X_SC
                        ENDIF
                       ENDIF
                  ENDIF
       L=L+1

       IF (M.EQ.1) THEN
       HXR=HX*CT1+HZ*ST1
       HZR=-HX*ST1+HZ*CT1
       ELSE
       HXR=HX*CT2+HZ*ST2
       HZR=-HX*ST2+HZ*CT2
       ENDIF

       GX=GX+HXR*A(L)
       GY=GY+HY *A(L)
  5    GZ=GZ+HZR*A(L)

  4   CONTINUE
  3   CONTINUE
  2   CONTINUE
  1   CONTINUE

      BX=GX
      BY=GY
      BZ=GZ

      RETURN
      END

!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
      SUBROUTINE FULL_RC_T04 (IOPR,PS,X,Y,Z,BXSRC,BYSRC,BZSRC,BXPRC, &
           BYPRC, &
        BZPRC)
!
!   CALCULATES GSM FIELD COMPONENTS OF THE SYMMETRIC (SRC) AND PARTIAL (PRC) COMPONENTS OF THE RING CURRENT
!   SRC  PROVIDES A DEPRESSION OF -28 nT AT EARTH
!   PRC  CORRESPONDS TO THE PRESSURE DIFFERENCE OF 2 nPa BETWEEN MIDNIGHT AND NOON RING CURRENT
!             PARTICLE PRESSURE AND YIELDS A DEPRESSION OF -17 nT AT X=-6Re
!
!   SC_SY AND SC_PR ARE SCALING FACTORS FOR THE SYMMETRIC AND PARTIAL COMPONENTS:
!          VALUES LARGER THAN 1 RESULT IN SPATIALLY LARGER CURRENTS
!
!   PHI IS THE ROTATION ANGLE IN RADIANS OF THE PARTIAL RING CURRENT (MEASURED FROM MIDNIGHT TOWARD DUSK)
!
!     IOPR -  A RING CURRENT CALCULATION FLAG (FOR LEAST-SQUARES FITTING ONLY):
!             IOPR=0 - BOTH SRC AND PRC FIELDS ARE CALCULATED
!             IOPR=1 - SRC ONLY
!             IOPR=2 - PRC ONLY
!
        IMPLICIT REAL*8 (A-H,O-Z)
        DIMENSION C_SY(86),C_PR(86)
      save
        COMMON /RCPAR/ SC_SY,SC_PR,PHI
!
        DATA C_SY/1675.694858d0,1780.006388d0,-961.6082149d0,-1668.914259d0, &
      -27.40437029d0,-107.4169670d0,27.76189943d0,92.89740503d0,-43.92949274d0, &
      -403.6444072d0,6.167161865d0,298.2779761d0,-1680.779044d0,-1780.933039d0, &
      964.1861088d0,1670.988659d0,27.48864650d0,107.7809519d0,-27.84600972d0, &
      -93.20691865d0,44.28496784d0,404.4537249d0,-6.281958730d0,-298.6050952d0, &
      -7.971914848d0,2.017383761d0,-1.492230168d0,-1.957411655d0,-.08525523181d0, &
      -.3811813235d0,.08446716725d0,.3215044399d0,-.7141912767d0,-.9086294596d0, &
      .2966677742d0,-.04736679933d0,-11.38731325d0,.1719795189d0,1.356233066d0, &
      .8613438429d0,-.09143823092d0,-.2593979098d0,.04244838338d0,.06318383319d0, &
      -.5861372726d0,-.03368780733d0,-.07104470269d0,-.06909052953d0, &
      -60.18659631d0,-32.87563877d0,11.76450433d0,5.891673644d0,2.562360333d0, &
      6.215377232d0,-1.273945165d0,-1.864704763d0,-5.394837143d0,-8.799382627d0, &
      3.743066561d0,-.7649164511d0,57.09210569d0,32.61236511d0,-11.28688017d0, &
      -5.849523392d0,-2.470635922d0,-5.961417272d0,1.230031099d0,1.793192595d0, &
      5.383736074d0,8.369895153d0,-3.611544412d0,.7898988697d0,7.970609948d0, &
      7.981216562d0,35.16822497d0,12.45651654d0,1.689755359d0,3.678712366d0, &
      23.66117284d0,6.987136092d0,6.886678677d0,20.91245928d0,1.650064156d0, &
      3.474068566d0,.3474715765d0,.6564043111d0/

        DATA C_PR/-64820.58481d0,-63965.62048d0,66267.93413d0,135049.7504d0, &
      -36.56316878d0,124.6614669d0,56.75637955d0,-87.56841077d0,5848.631425d0, &
      4981.097722d0,-6233.712207d0,-10986.40188d0,68716.52057d0,65682.69473d0, &
      -69673.32198d0,-138829.3568d0,43.45817708d0,-117.9565488d0,-62.14836263d0, &
      79.83651604d0,-6211.451069d0,-5151.633113d0,6544.481271d0,11353.03491d0, &
      23.72352603d0,-256.4846331d0,25.77629189d0,145.2377187d0,-4.472639098d0, &
      -3.554312754d0,2.936973114d0,2.682302576d0,2.728979958d0,26.43396781d0, &
      -9.312348296d0,-29.65427726d0,-247.5855336d0,-206.9111326d0,74.25277664d0, &
      106.4069993d0,15.45391072d0,16.35943569d0,-5.965177750d0,-6.079451700d0, &
      115.6748385d0,-35.27377307d0,-32.28763497d0,-32.53122151d0,93.74409310d0, &
      84.25677504d0,-29.23010465d0,-43.79485175d0,-6.434679514d0,-6.620247951d0, &
      2.443524317d0,2.266538956d0,-43.82903825d0,6.904117876d0,12.24289401d0, &
      17.62014361d0,152.3078796d0,124.5505289d0,-44.58690290d0,-63.02382410d0, &
      -8.999368955d0,-9.693774119d0,3.510930306d0,3.770949738d0,-77.96705716d0, &
      22.07730961d0,20.46491655d0,18.67728847d0,9.451290614d0,9.313661792d0, &
      644.7620970d0,418.2515954d0,7.183754387d0,35.62128817d0,19.43180682d0, &
      39.57218411d0,15.69384715d0,7.123215241d0,2.300635346d0,21.90881131d0, &
      -.01775839370d0,.3996346710d0/

        CALL SRC_PRC_T04 (IOPR,SC_SY,SC_PR,PHI,PS,X,Y,Z,HXSRC,HYSRC, &
             HZSRC, &
            HXPRC,HYPRC,HZPRC)

        X_SC=SC_SY-1.D0
        IF (IOPR.EQ.0.OR.IOPR.EQ.1) THEN
          CALL RC_SHIELD_T04 (C_SY,PS,X_SC,X,Y,Z,FSX,FSY,FSZ)
        ELSE
           FSX=0.D0
           FSY=0.D0
           FSZ=0.D0
        ENDIF

        X_SC=SC_PR-1.D0
        IF (IOPR.EQ.0.OR.IOPR.EQ.2) THEN
          CALL RC_SHIELD_T04 (C_PR,PS,X_SC,X,Y,Z,FPX,FPY,FPZ)
        ELSE
           FPX=0.D0
           FPY=0.D0
           FPZ=0.D0
        ENDIF

        BXSRC=HXSRC+FSX
        BYSRC=HYSRC+FSY
        BZSRC=HZSRC+FSZ

        BXPRC=HXPRC+FPX
        BYPRC=HYPRC+FPY
        BZPRC=HZPRC+FPZ

        RETURN
        END
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

       SUBROUTINE SRC_PRC_T04 (IOPR,SC_SY,SC_PR,PHI,PS,X,Y,Z,BXSRC, &
           BYSRC, &
          BZSRC,BXPRC,BYPRC,BZPRC)
!
!   RETURNS FIELD COMPONENTS FROM A MODEL RING CURRENT, INCLUDING ITS SYMMETRIC PART
!     AND A PARTIAL RING CURRENT, CLOSED VIA BIRKELAND CURRENTS. BASED ON RESULTS, DESCRIBED
!     IN A PAPER "MODELING THE INNER MAGNETOSPHERE: ASYMMETRIC RING CURRENT AND REGION 2
!     BIRKELAND CURRENTS REVISITED" (JGR, DEC.2000).
!
!     IOPR -  A RING CURRENT CALCULATION FLAG (FOR LEAST-SQUARES FITTING ONLY):
!             IOPR=0 - BOTH SRC AND PRC FIELDS ARE CALCULATED
!             IOPR=1 - SRC ONLY
!             IOPR=2 - PRC ONLY
!
!     SC_SY &  SC_PR ARE SCALE FACTORS FOR THE ABOVE COMPONENTS;  TAKING SC<1 OR SC>1 MAKES THE CURRENTS
!                      SHRINK OR EXPAND, RESPECTIVELY.
!
!   PHI IS THE ROTATION ANGLE (RADIANS) OF THE PARTIAL RING CURRENT (MEASURED FROM MIDNIGHT TOWARD DUSK)
!
        IMPLICIT REAL*8 (A-H,O-Z)
      save
!
!   1.  TRANSFORM TO TILTED COORDINATES (i.e., SM coordinates):
!
        CPS=DCOS(PS)
        SPS=DSIN(PS)

        XT=X*CPS-Z*SPS
        ZT=Z*CPS+X*SPS
!
!   2.  SCALE THE COORDINATES FOR THE SYMMETRIC AND PARTIAL RC COMPONENTS:
!
        XTS=XT/SC_SY    !  SYMMETRIC
        YTS=Y /SC_SY
        ZTS=ZT/SC_SY

        XTA=XT/SC_PR    !  PARTIAL
        YTA=Y /SC_PR
        ZTA=ZT/SC_PR
!
!   3.  CALCULATE COMPONENTS OF THE TOTAL FIELD IN THE TILTED (SOLAR-MAGNETIC) COORDINATE SYSTEM:
!
!
!    3a. SYMMETRIC FIELD:
!
        IF (IOPR.LE.1) CALL RC_SYMM_T04(XTS,YTS,ZTS,BXS,BYS,BZS)
        IF (IOPR.EQ.0.OR.IOPR.EQ.2) &
                       CALL PRC_SYMM_T04(XTA,YTA,ZTA,BXA_S,BYA_S,BZA_S)

!    3b. ROTATE THE SCALED SM COORDINATES BY PHI AROUND ZSM AXIS AND CALCULATE QUADRUPOLE PRC FIELD
!         IN THOSE COORDS:

        CP=DCOS(PHI)
        SP=DSIN(PHI)
        XR=XTA*CP-YTA*SP
        YR=XTA*SP+YTA*CP

        IF (IOPR.EQ.0.OR.IOPR.EQ.2) &
                       CALL PRC_QUAD_T04(XR,YR,ZTA,BXA_QR,BYA_QR,BZA_Q)

!    3c. TRANSFORM THE QUADRUPOLE FIELD COMPONENTS BACK TO THE SM COORDS:
!
        BXA_Q= BXA_QR*CP+BYA_QR*SP
        BYA_Q=-BXA_QR*SP+BYA_QR*CP

!    3d. FIND THE TOTAL FIELD OF PRC (SYMM.+QUADR.) IN THE SM COORDS:
!
        BXP=BXA_S+BXA_Q
        BYP=BYA_S+BYA_Q
        BZP=BZA_S+BZA_Q
!
!   4.  TRANSFORM THE FIELDS OF BOTH PARTS OF THE RING CURRENT BACK TO THE GSM SYSTEM:
!
        BXSRC=BXS*CPS+BZS*SPS   !    SYMMETRIC RC
        BYSRC=BYS
        BZSRC=BZS*CPS-BXS*SPS
!
        BXPRC=BXP*CPS+BZP*SPS   !    PARTIAL RC
        BYPRC=BYP
        BZPRC=BZP*CPS-BXP*SPS
!
        RETURN
        END
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
      SUBROUTINE RC_SYMM_T04 (X,Y,Z,BX,BY,BZ)
      IMPLICIT  REAL * 8  (A - H, O - Z)
      save
      DATA DS,DC/1.D-2,0.99994999875D0/, D/1.D-4/,DRD/5.D3/  ! DS=SIN(THETA) AT THE BOUNDARY OF THE LINEARITY
!                                                                        REGION; DC=SQRT(1-DS**2);  DRD=1/(2*D)
      RHO2=X**2+Y**2
      R2=RHO2+Z**2
      R=DSQRT(R2)
      RP=R+D
      RM=R-D
      SINT=DSQRT(RHO2)/R
      COST=Z/R

      IF (SINT.LT.DS) THEN  !  TOO CLOSE TO THE Z-AXIS; USING A LINEAR APPROXIMATION A_PHI~SINT,
!                                    TO AVOID THE SINGULARITY PROBLEM
        A=AP_T04(R,DS,DC)/DS
        DARDR=(RP*AP_T04(RP,DS,DC)-RM*AP_T04(RM,DS,DC))*DRD
        FXY=Z*(2.D0*A-DARDR)/(R*R2)
        BX=FXY*X
        BY=FXY*Y
        BZ=(2.D0*A*COST**2+DARDR*SINT**2)/R

       ELSE

        THETA=DATAN2(SINT,COST)
        TP=THETA+D
        TM=THETA-D
        SINTP=DSIN(TP)
        SINTM=DSIN(TM)
        COSTP=DCOS(TP)
        COSTM=DCOS(TM)
        BR=(SINTP*AP_T04(R,SINTP,COSTP)-SINTM*AP_T04(R,SINTM,COSTM)) &
             /(R*SINT)*DRD
        BT=(RM*AP_T04(RM,SINT,COST)-RP*AP_T04(RP,SINT,COST))/R*DRD
        FXY=(BR+BT*COST/SINT)/R
        BX=FXY*X
        BY=FXY*Y
        BZ=BR*COST-BT*SINT

      ENDIF

      RETURN
      END
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
      DOUBLE PRECISION FUNCTION AP_T04(R,SINT,COST)
!
!      Calculates azimuthal component of the vector potential of the symmetric
!  part of the model ring current.
!
      IMPLICIT  REAL * 8  (A - H, O - Z)
      save
      LOGICAL PROX   !  INDICATES WHETHER WE ARE TOO CLOSE TO THE AXIS OF SYMMETRY, WHERE THE INVERSION
!                                                             OF DIPOLAR COORDINATES BECOMES INACCURATE
      DATA A1,A2,RRC1,DD1,RRC2,DD2,P1,R1,DR1,DLA1,P2,R2,DR2,DLA2,P3, &
      R3,DR3/ &
      -563.3722359d0,425.0891691d0,4.150588549d0,2.266150226d0, &
       3.334503403d0,3.079071195d0,.02602428295d0,8.937790598d0,3.327934895d0, &
      .4487061833d0,.09125832351d0,6.243029867d0,1.750145910d0,.4181957162d0, &
      .06106691992d0,2.079908581d0,.6828548533d0/

      PROX=.FALSE.
      SINT1=SINT
      COST1=COST
      IF (SINT1.LT.1.D-2) THEN  !  TOO CLOSE TO Z-AXIS;  USE LINEAR INTERPOLATION BETWEEN SINT=0 & SINT=0.01
        SINT1=1.D-2
        COST1=.99994999875d0
        PROX=.TRUE.
      ENDIF

         ALPHA=SINT1**2/R         !  R,THETA -> ALPHA,GAMMA
         GAMMA=COST1/R**2

         ARG1=-((R-R1)/DR1)**2-(COST1/DLA1)**2
         ARG2=-((R-R2)/DR2)**2-(COST1/DLA2)**2
         ARG3=-((R-R3)/DR3)**2

         IF (ARG1.LT.-500.D0) THEN        !   TO PREVENT "FLOATING UNDERFLOW" CRASHES
           DEXP1=0.D0
         ELSE
           DEXP1=DEXP(ARG1)
         ENDIF

         IF (ARG2.LT.-500.D0) THEN
           DEXP2=0.D0
         ELSE
           DEXP2=DEXP(ARG2)
         ENDIF

         IF (ARG3.LT.-500.D0) THEN
           DEXP3=0.D0
         ELSE
           DEXP3=DEXP(ARG3)
         ENDIF


         ALPHA_S=ALPHA*(1.D0+P1*DEXP1+P2*DEXP2+P3*DEXP3)     !  ALPHA -> ALPHA_S  (DEFORMED)

         GAMMA_S=GAMMA
         GAMMAS2=GAMMA_S**2


         ALSQH=ALPHA_S**2/2.D0            !  ALPHA_S,GAMMA_S -> RS,SINTS,COSTS
         F=64.D0/27.D0*GAMMAS2+ALSQH**2
         Q=(DSQRT(F)+ALSQH)**(1.D0/3.D0)
         C=Q-4.D0*GAMMAS2**(1.D0/3.D0)/(3.D0*Q)
         IF (C.LT.0.D0) C=0.D0
         G=DSQRT(C**2+4.D0*GAMMAS2**(1.D0/3.D0))
         RS=4.D0/((DSQRT(2.D0*G-C)+DSQRT(C))*(G+C))
         COSTS=GAMMA_S*RS**2
         SINTS=DSQRT(1.D0-COSTS**2)
         RHOS=RS*SINTS
! jah, foresys : Result of assignment to RHOS2 is not used
! jah, RHOS2=RHOS**2
!         RHOS2=RHOS**2
         ZS=RS*COSTS
!
!  1st loop:

         P=(RRC1+RHOS)**2+ZS**2+DD1**2
         XK2=4.D0*RRC1*RHOS/P
         XK=SQRT(XK2)
         XKRHO12=XK*SQRT(RHOS)
!
      XK2S=1.D0-XK2
      DL=DLOG(1.D0/XK2S)
      ELK=1.38629436112d0+XK2S*(0.09666344259D0+XK2S*(0.03590092383d0+ &
           XK2S*(0.03742563713d0+XK2S*0.01451196212d0))) +DL* &
           (0.5D0+XK2S*(0.12498593597D0+XK2S*(0.06880248576D0+ &
           XK2S*(0.03328355346D0+XK2S*0.00441787012D0))))
      ELE=1.D0+XK2S*(0.44325141463D0+XK2S*(0.0626060122D0+XK2S* &
            (0.04757383546D0+XK2S*0.01736506451D0))) +DL* &
           XK2S*(0.2499836831D0+XK2S*(0.09200180037D0+XK2S* &
             (0.04069697526D0+XK2S*0.00526449639D0)))
!
      APHI1=((1.D0-XK2*0.5D0)*ELK-ELE)/XKRHO12
!
!  2nd loop:

         P=(RRC2+RHOS)**2+ZS**2+DD2**2
         XK2=4.D0*RRC2*RHOS/P
         XK=SQRT(XK2)
         XKRHO12=XK*SQRT(RHOS)
!
      XK2S=1.D0-XK2
      DL=DLOG(1.D0/XK2S)
      ELK=1.38629436112d0+XK2S*(0.09666344259D0+XK2S*(0.03590092383d0+ &
           XK2S*(0.03742563713d0+XK2S*0.01451196212d0))) +DL* &
           (0.5D0+XK2S*(0.12498593597D0+XK2S*(0.06880248576D0+ &
           XK2S*(0.03328355346D0+XK2S*0.00441787012D0))))
      ELE=1.D0+XK2S*(0.44325141463D0+XK2S*(0.0626060122D0+XK2S* &
            (0.04757383546D0+XK2S*0.01736506451D0))) +DL* &
           XK2S*(0.2499836831D0+XK2S*(0.09200180037D0+XK2S* &
             (0.04069697526D0+XK2S*0.00526449639D0)))
!
       APHI2=((1.D0-XK2*0.5D0)*ELK-ELE)/XKRHO12

       AP_T04=A1*APHI1+A2*APHI2
       IF (PROX) AP_T04=AP_T04*SINT/SINT1   !   LINEAR INTERPOLATION, IF TOO CLOSE TO THE Z-AXIS
!
       RETURN
       END
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
      SUBROUTINE PRC_SYMM_T04 (X,Y,Z,BX,BY,BZ)
      IMPLICIT  REAL * 8  (A - H, O - Z)
      save
      DATA DS,DC/1.D-2,0.99994999875D0/, D/1.D-4/,DRD/5.D3/  ! DS=SIN(THETA) AT THE BOUNDARY OF THE LINEARITY
!                                                                        REGION; DC=SQRT(1-DS**2);  DRD=1/(2*D)
      RHO2=X**2+Y**2
      R2=RHO2+Z**2
      R=DSQRT(R2)
      RP=R+D
      RM=R-D
      SINT=DSQRT(RHO2)/R
      COST=Z/R

      IF (SINT.LT.DS) THEN  !  TOO CLOSE TO THE Z-AXIS; USING A LINEAR APPROXIMATION A_PHI~SINT,
!                                    TO AVOID THE SINGULARITY PROBLEM
        A=APPRC_T04(R,DS,DC)/DS
        DARDR=(RP*APPRC_T04(RP,DS,DC)-RM*APPRC_T04(RM,DS,DC))*DRD
        FXY=Z*(2.D0*A-DARDR)/(R*R2)
        BX=FXY*X
        BY=FXY*Y
        BZ=(2.D0*A*COST**2+DARDR*SINT**2)/R

       ELSE

        THETA=DATAN2(SINT,COST)
        TP=THETA+D
        TM=THETA-D
        SINTP=DSIN(TP)
        SINTM=DSIN(TM)
        COSTP=DCOS(TP)
        COSTM=DCOS(TM)
        BR=(SINTP*APPRC_T04(R,SINTP,COSTP)-SINTM* &
             APPRC_T04(R,SINTM,COSTM)) &
             /(R*SINT)*DRD
        BT=(RM*APPRC_T04(RM,SINT,COST)-RP*APPRC_T04(RP,SINT,COST))/R*DRD
        FXY=(BR+BT*COST/SINT)/R
        BX=FXY*X
        BY=FXY*Y
        BZ=BR*COST-BT*SINT

      ENDIF

      RETURN
      END
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
      DOUBLE PRECISION FUNCTION APPRC_T04(R,SINT,COST)

!
!      Calculates azimuthal component of the vector potential of the symmetric
!  part of the model PARTIAL ring current.
!
      IMPLICIT  REAL * 8  (A - H, O - Z)
      save
      LOGICAL PROX
      DATA A1,A2,RRC1,DD1,RRC2,DD2,P1,ALPHA1,DAL1,BETA1,DG1,P2,ALPHA2, &
       DAL2,BETA2,DG2,BETA3,P3,ALPHA3,DAL3,BETA4,DG3,BETA5,Q0,Q1,ALPHA4, &
       DAL4,DG4,Q2,ALPHA5,DAL5,DG5,BETA6,BETA7 &
       /-80.11202281d0,12.58246758d0,6.560486035d0,1.930711037d0,3.827208119d0, &
      .7789990504d0,.3058309043d0,.1817139853d0,.1257532909d0,3.422509402d0, &
      .04742939676d0,-4.800458958d0,-.02845643596d0,.2188114228d0,2.545944574d0, &
      .00813272793d0,.35868244d0,103.1601001d0,-.00764731187d0,.1046487459d0, &
      2.958863546d0,.01172314188d0,.4382872938d0,.01134908150d0,14.51339943d0, &
      .2647095287d0,.07091230197d0,.01512963586d0,6.861329631d0,.1677400816d0, &
      .04433648846d0,.05553741389d0,.7665599464d0,.7277854652d0/

      PROX=.FALSE.
      SINT1=SINT
      COST1=COST
      IF (SINT1.LT.1.D-2) THEN  !  TOO CLOSE TO Z-AXIS;  USE LINEAR INTERPOLATION BETWEEN SINT=0 & SINT=0.01
        SINT1=1.D-2
        COST1=.99994999875d0
        PROX=.TRUE.
      ENDIF

         ALPHA=SINT1**2/R         !  R,THETA -> ALPHA,GAMMA
         GAMMA=COST1/R**2

         ARG1=-(GAMMA/DG1)**2
         ARG2=-((ALPHA-ALPHA4)/DAL4)**2-(GAMMA/DG4)**2

         IF (ARG1.LT.-500.D0) THEN        !   TO PREVENT "FLOATING UNDERFLOW" CRASHES
           DEXP1=0.D0
         ELSE
           DEXP1=DEXP(ARG1)
         ENDIF

         IF (ARG2.LT.-500.D0) THEN        !   TO PREVENT "FLOATING UNDERFLOW" CRASHES
           DEXP2=0.D0
         ELSE
           DEXP2=DEXP(ARG2)
         ENDIF

         ALPHA_S=ALPHA*(1.D0+P1/(1.D0+((ALPHA-ALPHA1)/DAL1)**2)**BETA1 &
       *DEXP1+P2*(ALPHA-ALPHA2)/(1.D0+((ALPHA-ALPHA2)/DAL2)**2)**BETA2 &
      /(1.D0+(GAMMA/DG2)**2)**BETA3 &
      +P3*(ALPHA-ALPHA3)**2/(1.D0+((ALPHA-ALPHA3)/DAL3)**2)**BETA4 &
      /(1.D0+(GAMMA/DG3)**2)**BETA5)     !  ALPHA -> ALPHA_S  (DEFORMED)

         GAMMA_S=GAMMA*(1.D0+Q0+Q1*(ALPHA-ALPHA4)*DEXP2               &!  GAMMA -> GAMMA_  (DEFORMED)
       +Q2*(ALPHA-ALPHA5)/(1.D0+((ALPHA-ALPHA5)/DAL5)**2)**BETA6 &
       /(1.D0+(GAMMA/DG5)**2)**BETA7)

         GAMMAS2=GAMMA_S**2

         ALSQH=ALPHA_S**2/2.D0                            !  ALPHA_S,GAMMA_S -> RS,SINTS,COSTS
         F=64.D0/27.D0*GAMMAS2+ALSQH**2
         Q=(DSQRT(F)+ALSQH)**(1.D0/3.D0)
         C=Q-4.D0*GAMMAS2**(1.D0/3.D0)/(3.D0*Q)
         IF (C.LT.0.D0) C=0.D0
         G=DSQRT(C**2+4.D0*GAMMAS2**(1.D0/3.D0))
         RS=4.D0/((DSQRT(2.D0*G-C)+DSQRT(C))*(G+C))
         COSTS=GAMMA_S*RS**2
         SINTS=DSQRT(1.D0-COSTS**2)
         RHOS=RS*SINTS
! jah, foresys : Result of assignment to RHOS2 is not used
! jah, RHOS2=RHOS**2
!         RHOS2=RHOS**2
         ZS=RS*COSTS
!
!  1st loop:

         P=(RRC1+RHOS)**2+ZS**2+DD1**2
         XK2=4.D0*RRC1*RHOS/P
         XK=SQRT(XK2)
         XKRHO12=XK*SQRT(RHOS)
!
      XK2S=1.D0-XK2
      DL=DLOG(1.D0/XK2S)
      ELK=1.38629436112d0+XK2S*(0.09666344259D0+XK2S*(0.03590092383d0+ &
           XK2S*(0.03742563713d0+XK2S*0.01451196212d0))) +DL* &
           (0.5D0+XK2S*(0.12498593597D0+XK2S*(0.06880248576D0+ &
           XK2S*(0.03328355346D0+XK2S*0.00441787012D0))))
      ELE=1.D0+XK2S*(0.44325141463D0+XK2S*(0.0626060122D0+XK2S* &
            (0.04757383546D0+XK2S*0.01736506451D0))) +DL* &
           XK2S*(0.2499836831D0+XK2S*(0.09200180037D0+XK2S* &
             (0.04069697526D0+XK2S*0.00526449639D0)))
!
      APHI1=((1.D0-XK2*0.5D0)*ELK-ELE)/XKRHO12
!
!  2nd loop:

         P=(RRC2+RHOS)**2+ZS**2+DD2**2
         XK2=4.D0*RRC2*RHOS/P
         XK=SQRT(XK2)
         XKRHO12=XK*SQRT(RHOS)
!
      XK2S=1.D0-XK2
      DL=DLOG(1.D0/XK2S)
      ELK=1.38629436112d0+XK2S*(0.09666344259D0+XK2S*(0.03590092383d0+ &
           XK2S*(0.03742563713d0+XK2S*0.01451196212d0))) +DL* &
           (0.5D0+XK2S*(0.12498593597D0+XK2S*(0.06880248576D0+ &
           XK2S*(0.03328355346D0+XK2S*0.00441787012D0))))
      ELE=1.D0+XK2S*(0.44325141463D0+XK2S*(0.0626060122D0+XK2S* &
            (0.04757383546D0+XK2S*0.01736506451D0))) +DL* &
           XK2S*(0.2499836831D0+XK2S*(0.09200180037D0+XK2S* &
             (0.04069697526D0+XK2S*0.00526449639D0)))
!
      APHI2=((1.D0-XK2*0.5D0)*ELK-ELE)/XKRHO12

      APPRC_T04=A1*APHI1+A2*APHI2
      IF (PROX) APPRC_T04=APPRC_T04*SINT/SINT1   !   LINEAR INTERPOLATION, IF TOO CLOSE TO THE Z-AXIS
!
      RETURN
      END
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
         SUBROUTINE PRC_QUAD_T04 (X,Y,Z,BX,BY,BZ)
!
         IMPLICIT  REAL * 8  (A - H, O - Z)
      save

         DATA D,DD/1.D-4,2.D-4/, DS/1.D-2/,DC/0.99994999875D0/

         RHO2=X**2+Y**2
         R=DSQRT(RHO2+Z**2)
         RHO=DSQRT(RHO2)
         SINT=RHO/R
         COST=Z/R
         RP=R+D
         RM=R-D

         IF (SINT.GT.DS) THEN
           CPHI=X/RHO
           SPHI=Y/RHO
           BR=BR_PRC_Q_T04(R,SINT,COST)
           BT=BT_PRC_Q_T04(R,SINT,COST)
           DBRR=(BR_PRC_Q_T04(RP,SINT,COST)-BR_PRC_Q_T04(RM,SINT,COST))/ &
                DD
           THETA=DATAN2(SINT,COST)
           TP=THETA+D
           TM=THETA-D
           SINTP=DSIN(TP)
           COSTP=DCOS(TP)
           SINTM=DSIN(TM)
           COSTM=DCOS(TM)
           DBTT=(BT_PRC_Q_T04(R,SINTP,COSTP)- &
                BT_PRC_Q_T04(R,SINTM,COSTM))/DD
           BX=SINT*(BR+(BR+R*DBRR+DBTT)*SPHI**2)+COST*BT
           BY=-SINT*SPHI*CPHI*(BR+R*DBRR+DBTT)
           BZ=(BR*COST-BT*SINT)*CPHI
         ELSE
           ST=DS
           CT=DC
           IF (Z.LT.0.D0) CT=-DC
           THETA=DATAN2(ST,CT)
           TP=THETA+D
           TM=THETA-D
           SINTP=DSIN(TP)
           COSTP=DCOS(TP)
           SINTM=DSIN(TM)
           COSTM=DCOS(TM)
           BR=BR_PRC_Q_T04(R,ST,CT)
           BT=BT_PRC_Q_T04(R,ST,CT)
           DBRR=(BR_PRC_Q_T04(RP,ST,CT)-BR_PRC_Q_T04(RM,ST,CT))/DD
           DBTT=(BT_PRC_Q_T04(R,SINTP,COSTP)- &
                BT_PRC_Q_T04(R,SINTM,COSTM))/DD
           FCXY=R*DBRR+DBTT
           BX=(BR*(X**2+2.D0*Y**2)+FCXY*Y**2)/(R*ST)**2+BT*COST
           BY=-(BR+FCXY)*X*Y/(R*ST)**2
           BZ=(BR*COST/ST-BT)*X/R
         ENDIF

         RETURN
         END
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
      DOUBLE PRECISION FUNCTION BR_PRC_Q_T04 (R,SINT,COST)
!
!alculates the radial component of the "quadrupole" part of the model partial ring current.
!
      IMPLICIT  REAL * 8  (A - H, O - Z)
      save

! ALL LINEAR PARAMETERS HERE
! WERE MULTIPLIED BY 0.1,
! SO THAT THEY CORRESPOND TO P_0=1 nPa,
! RATHER THAN THE ORIGINAL VALUE OF 10 nPa
! ASSUMED IN THE BIOT-SAVART INTEGRAL

      DATA A1,A2,A3,A4,A5,A6,A7,A8,A9,A10,A11,A12,A13,A14,A15,A16,A17, &
      A18,XK1,AL1,DAL1,B1,BE1,XK2,AL2,DAL2,B2,BE2,XK3,XK4,AL3,DAL3,B3, &
      BE3,AL4,DAL4,DG1,AL5,DAL5,DG2,C1,C2,C3,AL6,DAL6,DRM/ &
      -21.2666329d0, 32.24527521d0,-6.062894078d0,7.515660734d0, &
       233.7341288d0,-227.1195714d0, 8.483233889d0,16.80642754d0, &
     -24.63534184d0,9.067120578d0,-1.052686913d0, -12.08384538d0, &
     18.61969572d0,-12.71686069d0,47017.35679d0,-50646.71204d0, &
      7746.058231d0,1.531069371d0,2.318824273d0,.1417519429d0, &
      .6388013110d-02, 5.303934488d0,4.213397467d0,.7955534018d0, &
      .1401142771d0,.2306094179d-01, 3.462235072d0,2.568743010d0, &
      3.477425908d0,1.922155110d0,.1485233485d0, .2319676273d-01, &
      7.830223587d0,8.492933868d0,.1295221828d0,.01753008801d0, &
      .01125504083d0,.1811846095d0,.04841237481d0,.01981805097d0, &
      6.557801891d0, 6.348576071d0,5.744436687d0,.2265212965d0, &
      .1301957209d0,.5654023158d0/

        SINT2=SINT**2
        COST2=COST**2
        SC=SINT*COST
        ALPHA=SINT2/R
        GAMMA=COST/R**2

        CALL FFS_T04(ALPHA,AL1,DAL1,F,FA,FS)
        D1=SC*F**XK1/((R/B1)**BE1+1.D0)
        D2=D1*COST2

        CALL FFS_T04(ALPHA,AL2,DAL2,F,FA,FS)
        D3=SC*FS**XK2/((R/B2)**BE2+1.D0)
        D4=D3*COST2

        CALL FFS_T04(ALPHA,AL3,DAL3,F,FA,FS)
        D5=SC*(ALPHA**XK3)*(FS**XK4)/((R/B3)**BE3+1.D0)
        D6=D5*COST2

        ARGA=((ALPHA-AL4)/DAL4)**2+1.D0
        ARGG=1.D0+(GAMMA/DG1)**2

        D7=SC/ARGA/ARGG
        D8=D7/ARGA
        D9=D8/ARGA
        D10=D9/ARGA

        ARGA=((ALPHA-AL5)/DAL5)**2+1.D0
        ARGG=1.D0+(GAMMA/DG2)**2

        D11=SC/ARGA/ARGG
        D12=D11/ARGA
        D13=D12/ARGA
        D14=D13/ARGA


        D15=SC/(R**4+C1**4)
        D16=SC/(R**4+C2**4)*COST2
        D17=SC/(R**4+C3**4)*COST2**2

        CALL FFS_T04(ALPHA,AL6,DAL6,F,FA,FS)
        D18=SC*FS/(1.D0+((R-1.2D0)/DRM)**2)

        BR_PRC_Q_T04=A1*D1+A2*D2+A3*D3+A4*D4+A5*D5+A6*D6+A7*D7+A8*D8+A9* &
             D9+ &
        A10*D10+A11*D11+A12*D12+A13*D13+A14*D14+A15*D15+A16*D16+A17*D17+ &
         A18*D18
!
        RETURN
        END
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
        DOUBLE PRECISION FUNCTION BT_PRC_Q_T04 (R,SINT,COST)
!
!alculates the Theta component of the "quadrupole" part of the model partial ring current.
!
        IMPLICIT  REAL * 8  (A - H, O - Z)
      save

! ALL LINEAR PARAMETERS HERE
! WERE MULTIPLIED BY 0.1,
! SO THAT THEY CORRESPOND TO P_0=1 nPa,
! RATHER THAN THE ORIGINAL VALUE OF 10 nPa
! ASSUMED IN THE BIOT-SAVART INTEGRAL

      DATA A1,A2,A3,A4,A5,A6,A7,A8,A9,A10,A11,A12,A13,A14,A15,A16,A17, &
      XK1,AL1,DAL1,B1,BE1,XK2,AL2,DAL2,BE2,XK3,XK4,AL3,DAL3,B3,BE3,AL4,&
      DAL4,DG1,AL5,DAL5,DG2,C1,C2,C3 &
      /12.74640393d0,-7.516393516d0,  -5.476233865d0,3.212704645d0, &
      -59.10926169d0,46.62198189d0,-.01644280062d0, .1234229112d0, &
      -.08579198697d0,.01321366966d0,.8970494003d0,9.136186247d0,  &
      -38.19301215d0,21.73775846d0,-410.0783424d0,-69.90832690d0, &
      -848.8543440d0, 1.243288286d0,.2071721360d0,.05030555417d0, &
      7.471332374d0,3.180533613d0, 1.376743507d0,.1568504222d0, &
      .02092910682d0,1.985148197d0,.3157139940d0, 1.056309517d0, &
      .1701395257d0,.1019870070d0,6.293740981d0,5.671824276d0,  &
      .1280772299d0,.02189060799d0,.01040696080d0,.1648265607d0, &
      .04701592613d0, .01526400086d0,12.88384229d0,3.361775101d0, &
       23.44173897d0 /

        SINT2=SINT**2
        COST2=COST**2
! jah, foresys : Result of assignment to SC is not used
! jah,        SC=SINT*COST
        ALPHA=SINT2/R
        GAMMA=COST/R**2

        CALL FFS_T04(ALPHA,AL1,DAL1,F,FA,FS)
        D1=F**XK1/((R/B1)**BE1+1.D0)
        D2=D1*COST2

        CALL FFS_T04(ALPHA,AL2,DAL2,F,FA,FS)
        D3=FA**XK2/R**BE2
        D4=D3*COST2

        CALL FFS_T04(ALPHA,AL3,DAL3,F,FA,FS)
        D5=FS**XK3*ALPHA**XK4/((R/B3)**BE3+1.D0)
        D6=D5*COST2

        CALL FFS_T04(GAMMA,0.D0,DG1,F,FA,FS)
        FCC=(1.D0+((ALPHA-AL4)/DAL4)**2)
        D7 =1.D0/FCC*FS
        D8 =D7/FCC
        D9 =D8/FCC
        D10=D9/FCC

        ARG=1.D0+((ALPHA-AL5)/DAL5)**2
        D11=1.D0/ARG/(1.D0+(GAMMA/DG2)**2)
        D12=D11/ARG
        D13=D12/ARG
        D14=D13/ARG

        D15=1.D0/(R**4+C1**2)
        D16=COST2/(R**4+C2**2)
        D17=COST2**2/(R**4+C3**2)
!
        BT_PRC_Q_T04=A1*D1+A2*D2+A3*D3+A4*D4+A5*D5+A6*D6+A7*D7+A8*D8+A9* &
             D9+ &
         A10*D10+A11*D11+A12*D12+A13*D13+A14*D14+A15*D15+A16*D16+A17*D17
!
       RETURN
       END
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

       SUBROUTINE FFS_T04(A,A0,DA,F,FA,FS)
       IMPLICIT  REAL * 8  (A - H, O - Z)
      save
       SQ1=DSQRT((A+A0)**2+DA**2)
       SQ2=DSQRT((A-A0)**2+DA**2)
       FA=2.D0/(SQ1+SQ2)
       F=FA*A
       FS=0.5D0*(SQ1+SQ2)/(SQ1*SQ2)*(1.D0-F*F)
       RETURN
       END
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
         SUBROUTINE RC_SHIELD_T04 (A,PS,X_SC,X,Y,Z,BX,BY,BZ)
!
       IMPLICIT  REAL * 8  (A - H, O - Z)
         DIMENSION A(86)
      save
!
         FAC_SC=(X_SC+1.D0)**3
!
         CPS=DCOS(PS)
         SPS=DSIN(PS)

         S3PS=2.D0*CPS
!
         PST1=PS*A(85)
         PST2=PS*A(86)

         ST1=DSIN(PST1)
         CT1=DCOS(PST1)
         ST2=DSIN(PST2)
         CT2=DCOS(PST2)

         X1=X*CT1-Z*ST1
         Z1=X*ST1+Z*CT1
         X2=X*CT2-Z*ST2
         Z2=X*ST2+Z*CT2
!
         L=0
         GX=0.D0
         GY=0.D0
         GZ=0.D0
!
         DO 1 M=1,2     !    M=1 IS FOR THE 1ST SUM ("PERP." SYMMETRY)
!                          AND M=2 IS FOR THE SECOND SUM ("PARALL." SYMMETRY)
             DO 2 I=1,3
                  P=A(72+I)
                  Q=A(78+I)
                  CYPI=DCOS(Y/P)
                  CYQI=DCOS(Y/Q)
                  SYPI=DSIN(Y/P)
                  SYQI=DSIN(Y/Q)
!
                DO 3 K=1,3
                   R=A(75+K)
                   S=A(81+K)
                   SZRK=DSIN(Z1/R)
                   CZSK=DCOS(Z2/S)
                   CZRK=DCOS(Z1/R)
                   SZSK=DSIN(Z2/S)
                     SQPR=DSQRT(1.D0/P**2+1.D0/R**2)
                     SQQS=DSQRT(1.D0/Q**2+1.D0/S**2)
                        EPR=DEXP(X1*SQPR)
                        EQS=DEXP(X2*SQQS)
!
                  DO 4 N=1,2  ! N=1 IS FOR THE FIRST PART OF EACH COEFFICIENT
!                                AND N=2 IS FOR THE SECOND ONE

                    DO 5 NN=1,2 !   NN = 1,2 FURTHER SPLITS THE COEFFICIENTS INTO 2 PARTS,
!                                         TO TAKE INTO ACCOUNT THE SCALE FACTOR DEPENDENCE

                    IF (M.EQ.1) THEN
                         FX=-SQPR*EPR*CYPI*SZRK  *FAC_SC
                         FY=EPR*SYPI*SZRK/P   *FAC_SC
                         FZ=-EPR*CYPI*CZRK/R  *FAC_SC
                       IF (N.EQ.1) THEN
                         IF (NN.EQ.1) THEN
                          HX=FX
                          HY=FY
                          HZ=FZ
                         ELSE
                          HX=FX*X_SC
                          HY=FY*X_SC
                          HZ=FZ*X_SC
                         ENDIF
                       ELSE
                         IF (NN.EQ.1) THEN
                          HX=FX*CPS
                          HY=FY*CPS
                          HZ=FZ*CPS
                         ELSE
                          HX=FX*CPS*X_SC
                          HY=FY*CPS*X_SC
                          HZ=FZ*CPS*X_SC
                         ENDIF
                       ENDIF

                     ELSE                            !   M.EQ.2
                         FX=-SPS*SQQS*EQS*CYQI*CZSK  *FAC_SC
                         FY=SPS/Q*EQS*SYQI*CZSK   *FAC_SC
                         FZ=SPS/S*EQS*CYQI*SZSK   *FAC_SC
                       IF (N.EQ.1) THEN
                        IF (NN.EQ.1) THEN
                          HX=FX
                          HY=FY
                          HZ=FZ
                        ELSE
                          HX=FX*X_SC
                          HY=FY*X_SC
                          HZ=FZ*X_SC
                        ENDIF
                       ELSE
                        IF (NN.EQ.1) THEN
                         HX=FX*S3PS
                         HY=FY*S3PS
                         HZ=FZ*S3PS
                        ELSE
                         HX=FX*S3PS*X_SC
                         HY=FY*S3PS*X_SC
                         HZ=FZ*S3PS*X_SC
                        ENDIF
                       ENDIF
                  ENDIF
       L=L+1

       IF (M.EQ.1) THEN
       HXR=HX*CT1+HZ*ST1
       HZR=-HX*ST1+HZ*CT1
       ELSE
       HXR=HX*CT2+HZ*ST2
       HZR=-HX*ST2+HZ*CT2
       ENDIF

       GX=GX+HXR*A(L)
       GY=GY+HY *A(L)
  5    GZ=GZ+HZR*A(L)

  4   CONTINUE
  3   CONTINUE
  2   CONTINUE
  1   CONTINUE

      BX=GX
      BY=GY
      BZ=GZ

      RETURN
      END
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
       SUBROUTINE DIPOLE_T04 (PS,X,Y,Z,BX,BY,BZ)
!
!      A DOUBLE PRECISION ROUTINE
!
!  CALCULATES GSM COMPONENTS OF A GEODIPOLE FIELD WITH THE DIPOLE MOMENT
!  CORRESPONDING TO THE EPOCH OF 2000.
!
!----INPUT PARAMETERS:
!     PS - GEODIPOLE TILT ANGLE IN RADIANS,
!     X,Y,Z - GSM COORDINATES IN RE (1 RE = 6371.2 km)
!
!----OUTPUT PARAMETERS:
!     BX,BY,BZ - FIELD COMPONENTS IN GSM SYSTEM, IN NANOTESLA.
!
      IMPLICIT REAL*8 (A-H,O-Z)
      save
      SPS=DSIN(PS)
      CPS=DCOS(PS)
      P=X**2
      U=Z**2
      V=3.D0*Z*X
      T=Y**2
      Q=30115.D0/DSQRT(P+T+U)**5
      BX=Q*((T+U-2.D0*P)*SPS-V*CPS)
      BY=-3.D0*Y*Q*(X*SPS+Z*CPS)
      BZ=Q*((P+T-2.D0*U)*CPS-V*SPS)
      RETURN
      END


!     Fin du modele T04_s

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
