! $Id: greens.f90,v 1.2 2007/07/23 16:00:57 meyer Exp $

MODULE greens_mod

  USE teq_mod
  USE teqGS_mod

  IMPLICIT NONE

  REAL(rq), DIMENSION(:), ALLOCATABLE, PRIVATE :: wge,xge,rge,zgle,zgue,dae,&
       wgo,xgo,rgo,zglo,zguo,dao
  REAL(rq), PRIVATE :: area_e,area_o
  REAL(rq), DIMENSION(:), ALLOCATABLE, PRIVATE :: wr,wv,wz
  REAL(rq), DIMENSION(:,:), ALLOCATABLE, PRIVATE :: wrk0,wrk1,wrk2


  ! The following parameters can each be either even or odd. The
  ! only restriction is that they be different, and not both odd.
  ! The total number of integrand evaluations required to compute
  ! the self-inductance is n_gauss_even*n_gauss_odd for rectangular
  ! and type 1 coils, 6*n_gauss_even*n_gauss_odd for type 2 coils.

CONTAINS

  SUBROUTINE g_fldp(rp,zp,br,bz,flx)
    USE teq_input_mod
    REAL(rq), INTENT(IN)  :: rp,zp
    REAL(rq), INTENT(OUT) :: br,bz,flx
    REAL(rq), DIMENSION(t_jmkm) :: fl,fcr,fcz

    CALL mutual_utils(t_rm,t_zm,rp,zp,fl,fcr,fcz,3)
    flx=-SUM(fl*t_crj/t_rm)*t_dr*t_dz/FOURPI
    br =-SUM(fcr*t_crj/t_rm)*t_dr*t_dz/FOURPI
    bz =-SUM(fcz*t_crj/t_rm)*t_dr*t_dz/FOURPI
  END SUBROUTINE g_fldp

  FUNCTION g_flxp(rp,zp) RESULT(flx)
    USE teq_input_mod
    REAL(rq), INTENT(IN) :: rp,zp
    REAL(rq) ff(t_jmkm),flx
    CALL mutual_utils(t_rm,t_zm,rp,zp,ff,ff,ff,0)
    flx=-SUM(ff*t_crj/t_rm)*t_dr*t_dz/FOURPI
  END FUNCTION g_flxp

  FUNCTION g_flxc(rp,zp) RESULT(flx)
    REAL(rq), INTENT(IN) :: rp,zp
    REAL(rq), DIMENSION(t_ncf) :: ff,fr,fz
    REAL(rq) flx
    CALL mutual_utils(t_rcf,t_zcf,rp,zp,ff,fr,fz,0)
    flx=1.0e+05*SUM(ff*t_ccf)
  END FUNCTION g_flxc

  SUBROUTINE g_flxfld(rp,zp,br,bz,fl)
    REAL(rq) rp,zp,br,bz,fl
    REAL(rq), DIMENSION(t_ncf) ::  ff,fcr,fcz
    CALL mutual_utils(t_rcf,t_zcf,rp,zp,ff,fcr,fcz,3)
    fl=1.0e5*SUM(ff*t_ccf)
    br=1.0e5*SUM(fcr*t_ccf)
    bz=1.0e5*SUM(fcz*t_ccf)
  END SUBROUTINE g_flxfld

  FUNCTION g_xslfind( r, t_dr, dzz ) RESULT(xslf)

    !***********************************************************************
    !                                                                      *
    !     Calculates the 1-turn inductance of a single axisymmetric coil   *
    !     of rectangular section (uses Grover formula if square).  Based   *
    !     on 4th order expansion in R, from formula for circular coils     *
    !     of rectang<ular section. (MKS units.)                            *
    !                                                                      *
    !        R       :  mean radius                                        *
    !        T_DR      :  radial build                                       *
    !        T_DZ      :  axial height                                       *
    !        XSLFIND := self inductance                                    *
    !                                                                      *
    !     Written by:  Jim Leuer 1982                                      *
    !     Updated to include Grover for square, Jim Leuer (8/87)           *
    !     Modified 12-Sep-88 RHB                                           *
    !                                                                      *
    !***********************************************************************
    REAL(rq), INTENT(IN) :: r,t_dr,dzz
    REAL(rq) :: xslf,co2a,d,u,v,w,wp,ba2,ba4,ca2,ca4,baca2,al,t1,t5a,t5b,&
         t5c,t5d,t5e,t5f,t5,t6a,t6b,t6c,t6d,t6e,t6,t_dz

    t_dz = ABS(dzz)
    IF( t_dz==t_dr ) then
       co2a   = t_dr/(2.0*r)
       co2a   = co2a*co2a
       xslf= r*(0.5*(1.+co2a/6.)*log(8./co2a)-0.84834+.2041*co2a)
    ELSE
       d      = sqrt(t_dz*t_dz+t_dr*t_dr)
       u      = t_dz*t_dz/t_dr/t_dr*log(d*d/t_dz/t_dz)
       v      = t_dr*t_dr/t_dz/t_dz*log(d*d/t_dr/t_dr)
       w      = t_dz/t_dr*atan2(t_dr,t_dz)
       wp     = t_dr/t_dz*atan2(t_dz,t_dr)
       ba2    = t_dz*t_dz/(r*r)
       ca2    = t_dr*t_dr/(r*r)
       ba4    = ba2*ba2
       ca4    = ca2*ca2
       baca2  = ba2*ca2
       al     = log(8.0*r/d)
       t1     = al + (1.0+u+v)/12.0 - 2.0*(w+wp)/3.0
       t5a    = (3*ba2+ca2)*al
       t5b    = ba2*u/2.0
       t5c    = -ca2*v/10.0
       t5d    = -16.0*ba2*w/5.0
       t5e    = 69.0*ba2/20.0
       t5f    = 221.0*ca2/60.0
       t5     = (t5a+t5b+t5c+t5d+t5e+t5f)/96.0
       t6a    = (-30.0*ba4+35.0*baca2+22.0*ca4/3.0)*al
       t6b    = -(115.0*ba4-480.0*baca2)*u/12.0
       t6c    = -23.0*ca4*v/28.0
       t6d    = 256.0*(6.0*ba4-7.0*baca2)*w/21.0
       t6e    = -(36590.0*ba4-2035.0*baca2-11442.0*ca4)/840.0
       t6     = (t6a+t6b+t6c+t6d+t6e)/30720.0
       xslf   = r*(t1+t5+t6)
    END IF
    !
  END FUNCTION g_xslfind

  FUNCTION g_xsind(r0,z0,drr,dzz,ang1,ang2) RESULT(xslf)
    USE teq_input_mod
    ! Compute the self-inductance of a coil with parallelogram cross-section.
    ! The geometric center of the coil is at (r0,z0), distance between side
    ! edges  drr, distance between top and bottom edges dzz. Coil shape is
    ! given by the angles:
    !                  -2*pi < ang1, ang2 < 2*pi,
    ! according to the following scheme:
    !
    !        ang1           ang2              coil
    !       ------------------------------------------
    !         0         0, +/- pi/2         rectangle
    !        <>0        0, +/- pi/2          type 1
    !         0              <>0             type 2
    !        <>0      <>0& <>+/- pi/2       invalid
    !       ------------------------------------------
    !
    ! (ang2=0 has no valid geometric interpretation, but is allowed as a
    ! flag.) Double Integration in r is by odd order, gauss_odd, and even
    ! order, gauss_even, Gaussian quadrature. In "type-2" parallelograms
    ! the coil cross-section is subdivided into three disjoint regions, in
    ! each of which the integrand is smooth and the quadrature performed
    ! separately. The total self inductance is then computed as
    !
    !        L = L_1 + L_2 +L_3 +2*(M_12 +M_23 + M_31).
    !
    ! This routine uses the internal FUNCTION xmcc(...) to compute the mutual
    ! inductance of two coils.
    !
    ! Ref: M. W. Garrett, J. Appl. Phys 34, 2567 (1963). 

    REAL(rq) xslf,r0,z0,drr,dzz,ang1,ang2,area_1e,area_2e,area_3e,area_1o,&
         area_2o,area_3o,tacrit,delr,hdelr,hdr,hdz,rll,rlr,rscale,r2,sumi,&
         sumj,ta,tabs,zt1e,zt2e,zt3e,zt1o,zt2o,zt3o,z1,z2,rul,rur,delr1,&
         hdelr1,r01,delr2,hdelr2,delr3,hdelr3,r03,self1,self2,self3,mut12,&
         mut23,mut31
    INTEGER i,j,nevn,nodd
    SAVE nevn, nodd
    DATA nevn/0/, nodd/0/

    ! Check input parameters:
    IF(ang1/=0. .AND. (abs(ang2)/=.5*PI .AND. ang2/=0.))&
         call errdetec("ang1, ang2 incompatible in xsind",1)
    IF(r0<=0. .or. drr<=0. .or. dzz<=0.)&
         call errdetec("r0, drr,or dzz <= 0 in xsind",1)

    ! Compute Gaussian weights and abscissae on the normalized
    ! interval [-1, 1], if necessary:
    IF(nevn /= t_gauss_even .or. nodd /= t_gauss_odd)then
       IF(nevn/=0) DEALLOCATE(wge,xge,rge,zgle,zgue,dae,&
            wgo,xgo,rgo,zglo,zguo,dao)
       nevn=t_gauss_even
       nodd=t_gauss_odd
       ALLOCATE(wge(nevn),xge(nevn),rge(nevn),zgle(nevn),zgue(nevn),&
            dae(nevn),wgo(nodd),xgo(nodd),rgo(nodd),zglo(nodd),&
            zguo(nodd),dao(nodd))
       call gaussWtsAbs(-1._rq,1._rq,nevn,wge,xge)
       call gaussWtsAbs(-1._rq,1._rq,nodd,wgo,xgo)
    END IF

    ! Check Gaussian weights and abscissae if gauss_chck /= 0:
    IF(t_gauss_chck /= 0)then 
       IF(t_gauss_chck == 1)t_gauss_chck=0
       ! check weights:
       sumi=0.5_rq*SUM(wge)-1.0_rq
       sumj=0.5_rq*SUM(wgo)-1.0_rq
       write(*,*)"weight-check, even, odd:",sumi,sumj
       !check abscissae (integrate x**2 from x=1 to x=4):
       sumi=SUM(wge*(1.5_rq*xge+2.5_rq)**2)
       sumi=.5_rq*(4._rq-1.)*sumi-21._rq  ! correct result is 21.
       sumj=SUM(wge*(1.5_rq*xge+2.5_rq)**2)
       sumj=.5_rq*(4._rq-1.)*sumj-21._rq  ! correct result is 21.
       write(*,*)"abscissae-check, even, odd:",sumi,sumj
    END IF

    hdr=.5_rq*drr
    hdz=.5_rq*dzz
    z1=z0-hdz
    z2=z0+hdz
    area_e=0.
    area_o=0.

    IF(ang1==0.0 .and. (ang2==0.0 .or. abs(2.*abs(ang2)/PI -1.)<1.d-12))THEN
       DO i=1,nevn                                ! rectangular coil
          rge(i)=hdr*xge(i)+r0                    !   ------                 
          zgue(i)=z2                              !   |    |                
          zgle(i)=z1                              !   |    |               
          dae(i)=dzz                               !   |    |
       END DO
       DO j=1,nodd
          rgo(j)=hdr*xgo(j)+r0
          zguo(j)=z2 
          zglo(j)=z1
          dao(j)=dzz  
       END DO
       delr=drr                                
       xslf=g_xmcc(rge,wge,zgle,zgue,dae,delr,nevn,area_e,&
            rgo,wgo,zglo,zguo,dao,delr,nodd,area_o)
       xslf=xslf/(area_e*area_o)
       RETURN
    ELSEif(ang2 == 0.0 .or. abs(2.*abs(ang2)/PI-1._rq)<1.e3*errt_rq)then 
       ta=tan(ang1)                 ! "vertical" parallelogram coil:
       DO i=1,nevn                  ! (type 1)      /|  
          rge(i)=hdr*xge(i)+r0      !              / | .  
          zgue(i)=z2+(rge(i)-r0)*ta !              | |.
          zgle(i)=zgue(i)-dzz        !              | / ang1
          dae(i)=dzz                 !              |/.......
       END DO
       DO j=1,nodd
          rgo(j)=hdr*xgo(j)+r0
          zguo(j)=z2+(rgo(j)-r0)*ta
          zglo(j)=zguo(j)-dzz
          dao(j)=dzz
       END DO
       delr=drr
       xslf=g_xmcc(rge,wge,zgle,zgue,dae,delr,nevn,area_e,&
            rgo,wgo,zglo,zguo,dao,delr,nodd,area_o)
       xslf=xslf/(area_e*area_o)
       RETURN
    ELSE IF(ang1 == 0.0)then     ! "horizontal" parallelogram coil
       ta=tan(ang2)              ! (type 2): subdivide into 3 regions
       tabs=abs(ta)
       tacrit=dzz/drr  ! |tan(ang2)| for which area of region 2 = 0

       ! the following definitions 
       ! hold for all -2*pi<=ang2<=2*pi             --------   
       rll=r0-hdz/ta-hdr  ! lower-left             /|   |3 / 
       rlr=rll+drr         ! lower-right           / | 2 | /
       rul=rll+dzz/ta      ! upper-left           / 1|   |/ ang2
       rur=rul+drr         ! upper-right          --------.......
       delr=drr+dzz/tabs
       hdelr=.5_rq*delr
       IF(r0-hdelr < 0.)call errdetec(&
            "geometric parameters of type 2 coil are invalid",1)

       ! Region 1:

       IF(tabs > tacrit)then
          delr1=rul-rll
          r01=rll+.5_rq*delr1
       ELSE
          delr1=rlr-rll
          IF(ta>0.)then
             r01=rll+.5_rq*delr1
          ELSE
             r01=rul+.5_rq*delr1
          END IF
       END IF
       delr1=abs(delr1)            
       hdelr1=.5_rq*delr1
       ! Self inductance:
       DO i=1,nevn      
          rge(i)=hdelr1*xge(i)+r01
          IF(ta > 0.)then
             zgle(i)=z1
             zgue(i)=z1+(rge(i)-rll)*ta
          ELSE
             zgle(i)=z2+(rge(i)-rul)*ta
             zgue(i)=z2
          END IF
          dae(i)=zgue(i)-zgle(i)
       END DO
       DO j=1,nodd
          rgo(j)=hdelr1*xgo(j)+r01
          IF(ta > 0.)then
             zglo(j)=z1
             zguo(j)=z1+(rgo(j)-rll)*ta
          ELSE
             zglo(j)=z2+(rgo(j)-rul)*ta
             zguo(j)=z2
          END IF
          dao(j)=zguo(j)-zglo(j)
       END DO
       self1=g_xmcc(rge,wge,zgle,zgue,dae,delr1,nevn,area_1e,&
            rgo,wgo,zglo,zguo,dao,delr1,nodd,area_1o) 
       area_e=area_e+area_1e
       area_o=area_o+area_1o

       ! Mutual inductance with region 2:
       IF(tabs < tacrit)then    ! region 2 is a type-1 parallelogram
          IF(ta > 0.)then
             delr2=rul-rlr
          ELSEif(ta < 0.)then
             delr2=rll-rur
          ELSE
             call errdetec("ang2=0 in xsind, region 2",1)
          END IF
          hdelr2=.5_rq*delr2
          DO j=1,nodd
             rgo(j)=hdelr2*xgo(j)+r0
             IF(ta > 0.)then
                zglo(j)=z1+(rgo(j)-rlr)*ta
             ELSE
                zglo(j)=z1+(rgo(j)-rll)*ta
             END IF
             zguo(j)=zglo(j)+drr*tabs
             dao(j)=drr*tabs
          END DO
          mut12=g_xmcc(rge,wge,zgle,zgue,dae,delr1,nevn,area_1e,&
               rgo,wgo,zglo,zguo,dao,delr2,nodd,area_2o) 
       ELSEif(tabs > tacrit)then           ! region 2 is a rectangle
          IF(ta > 0.)then
             delr2=rlr-rul
          ELSE
             delr2=rur-rll
          END IF
          hdelr2=.5_rq*delr2
          DO j=1,nodd
             rgo(j)=hdelr2*xgo(j)+r0
             zguo(j)=z2
             zglo(j)=z1
             dao(j)=dzz
          END DO
          mut12=g_xmcc(rge,wge,zgle,zgue,dae,delr1,nevn,area_1e,&
               rgo,wgo,zglo,zguo,dao,delr2,nodd,area_2o) 
       ELSE                           ! region 2 has zero-thickness
          mut12=0.                         
       END IF

       ! Region 2:

       ! Self-inductance:
       IF(tabs<tacrit .AND. mut12>0.)then ! region 2 is type-1 parallelogram
          DO i=1,nevn
             rge(i)=hdelr2*xge(i)+r0
             IF(ta > 0.)then
                zgle(i)=z1+(rge(i)-rlr)*ta
             ELSE
                zgle(i)=z1+(rge(i)-rll)*ta
             END IF
             zgue(i)=zgle(i)+drr*tabs
             dae(i)=drr*tabs
          END DO
          self2=g_xmcc(rge,wge,zgle,zgue,dae,delr2,nevn,area_2e,&
               rgo,wgo,zglo,zguo,dao,delr2,nodd,area_2o) 
       ELSEif(tabs > tacrit)then                ! region 2 is rectangle
          DO i=1,nevn
             rge(i)=hdelr2*xge(i)+r0
             zgue(i)=z2
             zgle(i)=z1
             dae(i)=dzz
          END DO
          self2=g_xmcc(rge,wge,zgle,zgue,dae,delr2,nevn,area_2e,&
               rgo,wgo,zglo,zguo,dao,delr2,nodd,area_2o) 
       ELSE
          self2=0.
       END IF
       area_e=area_e+area_2e
       area_o=area_o+area_2o

       ! Mutual inductance with region 3:
       IF(tabs > tacrit)then
          delr3=rur-rlr
          r03=rlr+.5_rq*delr3
       ELSE
          delr3=rur-rul
          IF(ta > 0.)then
             r03=rul+.5_rq*delr3
          ELSE
             r03=rll+.5_rq*delr3
          END IF
       END IF
       delr3=abs(delr3)
       hdelr3=.5_rq*delr3
       DO j=1,nodd
          rgo(j)=hdelr3*xgo(j)+r03
          IF(ta > 0.)then
             zglo(j)=z2+(rgo(j)-rur)*ta
             zguo(j)=z2
          ELSE
             zglo(j)=z1
             zguo(j)=z1+(rgo(j)-rlr)*ta
          END IF
          dao(j)=zguo(j)-zglo(j)
       END DO
       mut23=g_xmcc(rge,wge,zgle,zgue,dae,delr2,nevn,area_2e,&
            rgo,wgo,zglo,zguo,dao,delr3,nodd,area_3o) 
       ! Region 3

       ! Self-inductance:
       DO i=1,nevn
          rge(i)=hdelr3*xge(i)+r03
          IF(ta > 0.)then
             zgle(i)=z2+(rge(i)-rur)*ta
             zgue(i)=z2
          ELSE
             zgle(i)=z1
             zgue(i)=z1+(rge(i)-rlr)*ta
          END IF
          dae(i)=zgue(i)-zgle(i)
       END DO
       self3=g_xmcc(rge,wge,zgle,zgue,dae,delr3,nevn,area_3e,&
            rgo,wgo,zglo,zguo,dao,delr3,nodd,area_3o)
       area_e=area_e+area_3e
       area_o=area_o+area_3o 

       ! Mutual inductance with region 1:
       DO j=1,nodd
          rgo(j)=hdelr1*xgo(j)+r01
          IF(ta > 0.)then
             zglo(j)=z1
             zguo(j)=z1+(rgo(j)-rll)*ta
          ELSE
             zglo(j)=z2+(rgo(j)-rul)*ta
             zguo(j)=z2
          END IF
          dao(j)=zguo(j)-zglo(j)
       END DO
       mut31=g_xmcc(rge,wge,zgle,zgue,dae,delr3,nevn,area_3e,&
            rgo,wgo,zglo,zguo,dao,delr1,nodd,area_1o)

       ! Compute total self-inductance:

       xslf=(self1+self2+self3+2.*(mut12+mut23+mut31))/(area_e*area_o)

       IF(t_gauss_chck == 2)then  ! useful for debugging
          write(*,*)"   "
          write(*,*)"a1,a2: ",ang1,ang2
          write(*,*)"L's: ",self1,self2,self3
          write(*,*)"M's: ",mut12,mut23,mut31
          write(*,*)"rll,rlr,rul,rur: ",rll,rlr,rul,rur
          write(*,*)"ta,tacrit,drr*dzz: ",ta,tacrit,drr*t_dz
          write(*,*)"r0's: ",r01,r0,r03
          write(*,*)"delr's: ",delr1,delr2,delr3
          write(*,*)"rge: ",rge
          write(*,*)"zgle: ",zgle
          write(*,*)"zgue: ",zgue
          write(*,*)"dae: ",dae
          write(*,*)"area_e,area_o: ",area_e,area_o
          write(*,*)"area_1e,area_1o: ",area_1e,area_1o
          write(*,*)"area_2e,area_2o: ",area_2e,area_2o
          write(*,*)"area_3e,area_3o: ",area_3e,area_3o
       END IF

       return
    ELSE
       call errdetec("bad input angle(s) in xsind",1)
    END IF

  END FUNCTION g_xsind

  FUNCTION g_xmrr(a,r,z) RESULT(xmr)
    REAL(rq) :: a,r,z,z2,apr2,r12,r1,k2,ek,kme,pmk,m,xmr
    REAL(rq) :: c2,rf,rd,rj

    ! Mutual inductance between equivalent ideal end-rings of two solenoids.
    !
    ! xmrr = M(S,S)/MU0 = {z*M(S,L)/MU0 + (2/3)*a*r*r1*[K-(2/k**2-1)(K-E)]} 
    !
    ! Ref: M. W. Garrett, J. Appl. Phys 34, 2567 (1963), eqs(8)-(9). 
    ! This function is even in z and invariant under interchange of a, r,
    ! where z = vertical separation of the rings and a,r their radii.

    z2=z*z
    apr2=(a+r)**2
    r12=z2+apr2
    r1=sqrt(r12)
    k2=4._rq*a*r/r12
    m=1._rq-k2
    c2=-k2*r12/apr2
    ek=r_f(ZERO,m,1._rq)                  ! K(k2)
    kme=k2*r_d(ZERO,m,1._rq)*THIRD            ! K(k2)-E(k2)
    pmk=-c2*r_j(ZERO,m,1._rq,1._rq+c2)*THIRD  ! PI(k2)-K(k2)
    xmr=0.5_rq*z2*(r1*kme-pmk*(a-r)**2/r1)&
         +2._rq*THIRD*a*r*r1*(ek-(2._rq/k2-1._rq)*kme)  ! n.b. no factor MU0

  END function g_xmrr

  FUNCTION g_xmcc(r1, w1, zl1, zu1, da1, dr1, n1, a1, r2, w2, zl2, zu2, da2,& 
       dr2, n2, a2) RESULT(xmc)

    ! Evaluate the double integral over r needed to compute the (mutual)
    ! inductance of two coils, which may coincide if they use different
    ! Gauss points. The areas obtained by integrating da1 and da2 are
    ! returned in a1 and a2, respectively.
    ! This FUNCTION uses FUNCTION xmrr(a,r,z) to compute contributions
    ! from ideal solenoidal END-rings.
    ! This is an internal FUNCTION used only by FUNCTION xsind.

    INTEGER n1, n2, i, j 
    REAL(rq), DIMENSION(n1) :: r1, w1, zl1, zu1, da1
    REAL(rq), DIMENSION(n2) :: r2, w2, zl2, zu2, da2
    REAL(rq) sumi, sumj, a1, a2, integral, dr1, dr2, xmc

    sumi=0
    a1=0
    a2=0
    DO i=1,n1
       sumj=0
       DO j=1,n2
          sumj=sumj+w2(j)*(-g_xmrr(r1(i),r2(j),zu1(i)-zu2(j))&
                           +g_xmrr(r1(i),r2(j),zu1(i)-zl2(j))&
                           +g_xmrr(r1(i),r2(j),zl1(i)-zu2(j))&
                           -g_xmrr(r1(i),r2(j),zl1(i)-zl2(j)))
       END DO
       sumi=sumi+w1(i)*sumj
       a1=a1+da1(i)*w1(i)
    END DO
    integral=.5_rq*dr1*.5_rq*dr2*sumi
    DO j=1,n2
       a2=a2+da2(j)*w2(j)
    END DO
    a1=a1*.5_rq*dr1
    a2=a2*.5_rq*dr2
    xmc=integral
  END FUNCTION g_xmcc

  SUBROUTINE get_greens
    INTEGER :: ii,n,j,k,l,ll,l0,l3,l4,l5,l6 
    REAL(rq), DIMENSION(t_ncf) ::  ff,fcr,fcz,rmt
    IF(t_ncf==t_ncfo) RETURN
    t_pfim=0
    ii=1
    t_ncfo=t_ncf
    CALL remark("Calculating pfim")
    !      SELF-INDUCTANCES [uH]...
    DO n=1,t_nc
       t_pfim(n,n)=0.4_rq*PI*g_xsind(t_rc(n),t_zc(n),t_drc(n),t_dzc(n),&
            t_ac(n),t_ac2(n))
    END DO
    !       Add external inductance
    DO n=1,t_nc
       t_pfim(n,n)=t_pfim(n,n)+t_lextc(n)
    END DO

    !
    !     MUTUAL INDUCTANCES [uH]...
    ii=1
    DO k=2,t_nc
       l4=1
       l3=t_loop0(k-1)+1
       l5=t_loop0(k)
       rmt=0
       ll=t_loop0(k-1)
       DO l=l3,l5
          call mutual(t_rcmf,t_zcmf,t_rcmf(l),t_zcmf(l),ll,ff,fcr,fcz,ii)
          rmt(:ll)=rmt(:ll)+ff(:ll)*t_ccf(l)
       END DO
       rmt(:ll)=rmt(:ll)*t_ccf(:ll)
       DO j=1,k-1
          l6=t_loop0(j)
          t_pfim(j,k)=0.1_rq*TWOPI*SUM(rmt(l4:l6))/(t_cc(j)*t_cc(k))
          t_pfim(k,j)=t_pfim(j,k)
          l4=t_loop0(j)+1
       END DO
    END DO
    IF(t_nloop0p/=0) THEN ! Mutuals between coils and loops
       ii=3
       DO l=1,t_nloop0p
          l0=1
          call mutual_utils(t_rcf,t_zcf,t_rloop(l),t_zloop(l),ff,fcr,fcz,ii)
          ff=ff*t_ccf
          fcr=fcr*t_ccf
          fcz=fcz*t_ccf
          DO n=1,t_nc
             t_plim(n,l,1)=TWOPI*1.0e-3*SUM(ff(l0:t_loop0(n)))/t_cc(n)
             t_plim(n,l,2)=10.0_rq*SUM(fcr(l0:t_loop0(n)))/t_cc(n)
             t_plim(n,l,3)=10.0_rq*SUM(fcz(l0:t_loop0(n)))/t_cc(n)
             l0=t_loop0(n)+1
          END DO
       END DO
    END IF
  END SUBROUTINE get_greens

  SUBROUTINE grnfcnst
    USE teq_input_mod
    REAL(rq) ::  aa,bb,drr,dzz,rmt
    INTEGER kl,i,kb,jb,ncl,l1,nn,l2,ii,jj,l,l0

    kl=1
    IF(t_nsym<=1) kl=t_km/2+1

    CALL remark("Calculating Greens functions")
    IF (ALLOCATED(wr)) THEN
       IF(t_jmkm/=SIZE(wr)) THEN
          DEALLOCATE(wr,wv,wz,wrk0,wrk1,wrk2)
       END IF
    END IF
    IF (.not.ALLOCATED(wr)) THEN
       ALLOCATE(wr(t_jmkm),wv(t_jmkm),wz(t_jmkm))
       ALLOCATE(wrk0(t_jm,t_km),wrk1(t_jm,t_km),wrk2(t_jm,t_km))
    END IF

    i=0
    t_gp=0
    aa=0
    bb=0
    DO kb=kl,t_km
       DO jb=1,t_jm
          jj=(jb-1)*(jb-t_jm)*(kb-1)*(kb-t_km)
          IF(jj==0) THEN
             i=i+1
             CALL mutual_utils(t_rm,t_zm,i_r(jb),i_z(kb),wv,wr,wz,0)
             wv=wv/t_rm
             wrk0=RESHAPE(wv,(/t_jm,t_km/))
             drr=t_dr
             dzz=t_dz
             IF(jb==1 .AND. i_r(1)<t_dr/2.0_rq) THEN
                drr=i_r(1)/2.0_rq
             END IF
             wrk0(jb,kb)=2*g_xsind(i_r(jb),i_z(kb),drr,dzz,aa,bb)/i_r(jb)
             IF(t_nsym<=1) THEN
                t_gp(:,:kl-1,i)=wrk0(:,:kl-1)+wrk0(:,t_km:kl+1:-1)
                t_gp(:,kl,i)=wrk0(:,kl)
             ELSE
                t_gp(:,:,i)=wrk0
             END IF
          END IF
       END DO
    END DO 
    ncl=t_nc
    IF(t_nsym<=1) ncl=t_nc/2
    l1=1
    nn=0
    rmt=-1.0e-4_rq*t_dr*t_dz/FOURPI
    IF(t_nloop0p/=0) THEN
       DO i=1,t_nloop0p
          CALL mutual_utils(t_rm,t_zm,t_rloop(i),t_zloop(i),wv,wr,wz,3)
          t_gpl(:,i,1)=rmt*wv/t_rm*TWOPI*1.e-4_rq
          t_gpl(:,i,2)=rmt*wr/t_rm
          t_gpl(:,i,3)=rmt*wz/t_rm
       END DO
    END IF
    DO i=1,ncl
       wrk0=0
       wrk1=0
       wrk2=0
       l2=t_loop0(i)
       DO ii=l1,l2
          IF(t_iferro(i)==1) THEN
             nn=nn+1
             CALL mutual_utils(t_rm,t_zm,t_rcf(ii),t_zcf(ii),wv,wr,wz,3)
             wrk0=RESHAPE(wv,(/t_jm,t_km/))
             wrk1=RESHAPE(wr/t_rm,(/t_jm,t_km/))
             wrk2=RESHAPE(wz/t_rm,(/t_jm,t_km/))
          ELSE
             IF(ii==l2) nn=nn+1
             CALL mutual_utils(t_rm,t_zm,t_rcf(ii),t_zcf(ii),wv,wr,wz,3)
              wrk0=wrk0+RESHAPE(wv,(/t_jm,t_km/))*t_ccf(ii)/t_cc(i)
             wrk1=wrk1+RESHAPE(wr/t_rm,(/t_jm,t_km/))*t_ccf(ii)/t_cc(i)
             wrk2=wrk2+RESHAPE(wz/t_rm,(/t_jm,t_km/))*t_ccf(ii)/t_cc(i)
          END IF
          IF(t_iferro(i)==1 .OR. ii==l2) THEN
             IF(t_nsym<=1) THEN
                t_gc(:,:kl,nn)  =wrk0(:,:kl)+wrk0(:,t_km:kl:-1)
                t_gfbr(:,:kl,nn)=wrk1(:,:kl)+wrk1(:,t_km:kl:-1)
                t_gfbz(:,:kl,nn)=wrk2(:,:kl)+wrk2(:,t_km:kl:-1)
             ELSE
                t_gc(:,:,nn)  =wrk0
                t_gfbr(:,:,nn)=wrk1
                t_gfbz(:,:,nn)=wrk2
             END IF
          END IF
       END DO
       l1=l2+1
    END DO
  END SUBROUTINE grnfcnst

END MODULE greens_mod

SUBROUTINE mutual(rin,zin,rout,zout,nin,fl,br,bz,inum)
  USE sep_utils
  IMPLICIT NONE
  INTEGER, INTENT(in) :: nin,inum
  REAL(rq), DIMENSION(nin), INTENT(IN)  :: rin,zin
  REAL(rq), DIMENSION(nin), INTENT(OUT) :: fl,br,bz
  REAL(rq), INTENT(IN) :: rout,zout
  CALL mutual_utils(rin,zin,rout,zout,fl,br,bz,inum)
END SUBROUTINE mutual
