C  fox.f -- uses Fox's algorithm to multiply two square matrices
C  FORTRAN 77 Fixed format Code
C
C  Input:
C      n: global order of matrices
C      A,B: the factor matrices (in row-major order)
C  Output:
C      C: the product matrix
C
C  Notes:
C      1.  Assumes the number of processes is a perfect square
C      2.  Assumes that n is evenly divisible by sqrt(p)
C
C  See Chap 7, pp. 113 & ff and pp. 125 & ff in PPMPI
C
      PROGRAM ParFox
      INCLUDE 'mpif.h'
      integer              ierr
C change the size of MAX to allow more entries.  It is
C limited to 1000 here for purposes of memory usage while
C testing
      integer              MAX
      parameter            ( MAX=1000 )
C grid array representation of each subscript
      integer              P, COMM, ROW_COMM, COL_COMM, Q
      integer              MY_ROW, MY_COL, MYRANK
      parameter            (P=1, COMM = 2, ROW_COMM = 3,
     +                      COL_COMM = 4, Q = 5,
     +                      MY_ROW=6, MY_COL=7, MYRANK=8)
      integer     	   grid_info(8)
      integer              n
      integer              n_bar
      integer              my_rank
      real                 A(MAX*MAX)
      real                 B(MAX*MAX)
      real                 C(MAX*MAX)
C
      call MPI_INIT( ierr)
      call MPI_COMM_RANK(MPI_COMM_WORLD,  my_rank, ierr )
C
      call Setup_grid( grid_info)
      if (my_rank .EQ. 0)  then
          print *, 'What is the order of the matrices?'
          read *, n
      endif
C
      call MPI_BCAST(n,1,MPI_INTEGER, 0, MPI_COMM_WORLD,ierr)
      n_bar = n/grid_info(Q)
C
      call Read_matrix('Enter A ', A,grid_info, n , n_bar)
      call Print_matrix('We read A =', A,grid_info,
     +                          n, n_bar)
C
      call Read_matrix('Enter B ', B,grid_info,n , n_bar)
      call Print_matrix('We read B =', B,grid_info,
     +                          n, n_bar )
C
      call Fox(n,  grid_info, A, B, C, n_bar)
C
      call Print_matrix('The product is', C,
     +                           grid_info, n, n_bar)
C
      call MPI_FINALIZE(ierr)
      end
C
C
C *******************************************************
      subroutine Setup_grid(grid)
C grid array representation of each subscript
      integer              P, COMM, ROW_COMM, COL_COMM, Q
      integer              MY_ROW, MY_COL, MYRANK
      parameter            (P=1, COMM = 2, ROW_COMM = 3,
     +                      COL_COMM = 4, Q= 5,
     +                      MY_ROW=6, MY_COL=7, MYRANK=8)
      integer   grid(8)
      INCLUDE 'mpif.h'
      integer ierr
      integer old_rank
      integer dimensions(0:1)
      logical wrap_around(0:1)
      integer coordinates(0:1)
      integer free_coords(0:1)
      real    gridreal
C
C  Set up Global Grid Information
      call MPI_COMM_SIZE(MPI_COMM_WORLD,  grid(P), ierr )
      call MPI_COMM_RANK(MPI_COMM_WORLD,  old_rank, ierr )
C
C  We assume p is a perfect square
      gridreal = grid(P)
      grid(Q) =  sqrt( gridreal )
      dimensions(0) = grid(Q)
      dimensions(1) = grid(Q)
C
C  We want a circular shift in second dimension.
C  Don't care about first
      wrap_around(0) = .true.
      wrap_around(1) = .true.
      call MPI_CART_CREATE(MPI_COMM_WORLD, 2, dimensions,
     +     wrap_around, 1,  grid(COMM), ierr)
      call MPI_COMM_RANK(grid(COMM),  grid(MYRANK), ierr)
      call MPI_CART_COORDS(grid(COMM), grid(MYRANK), 2,
     +                  coordinates, ierr)
      grid(MY_ROW) = coordinates(0)
      grid(MY_COL) = coordinates(1)
C
C  Set up row communicators
      free_coords(0) = 0
      free_coords(1) = 1
      call MPI_CART_SUB(grid(COMM), free_coords,
     +          grid(ROW_COMM), ierr)
C
C  Set up column communicators
      free_coords(0) = 1
      free_coords(1) = 0
      call MPI_CART_SUB(grid(COMM), free_coords,
     +      grid(COL_COMM), ierr)
      return
      end
C
C
C *******************************************************
      subroutine Fox(n, grid, local_A, local_B, local_C,
     +                      Order)
      integer              MAX
      parameter            ( MAX=1000 )
      integer              n
      integer              Order
      real  		   local_A(Order*Order)
      real  		   local_B(Order*Order)
      real  		   local_C(Order*Order)
C grid array representation of each subscript
      integer              P, COMM, ROW_COMM, COL_COMM, Q
      integer              MY_ROW, MY_COL, MYRANK
      parameter            (P=1, COMM = 2, ROW_COMM = 3,
     +                      COL_COMM = 4, Q = 5,
     +                      MY_ROW=6, MY_COL=7, MYRANK=8)
      integer     	   grid(8)
      INCLUDE 'mpif.h'
      integer ierr
      real                 temp_A(MAX*MAX)
C  matrix of A used during
C  the current stage
      integer              stage
      integer              bcast_root
      integer              n_bar
      integer              source
      integer              dest
      integer              status(MPI_STATUS_SIZE)
C
      n_bar = Order
      call Set_to_zero(local_C, n_bar)
C
C  Calculate addresses for circular shift of B
      source = MOD(grid(MY_ROW) + 1, grid(Q)  )
      dest =   MOD(grid(MY_ROW) + grid(Q) - 1, grid(Q) )
C
      do 100 stage = 0, grid(Q)-1
          bcast_root = MOD( grid(MY_ROW) + stage, grid(Q)  )
          if (bcast_root .EQ. grid(MY_COL))  then
              call MPI_BCAST(local_A,n_bar*n_bar,MPI_REAL,
     +             bcast_root, grid(ROW_COMM), ierr)
              call Local_matrix_multiply(local_A, local_B,
     +             local_C, n_bar)
          else
              call MPI_BCAST(temp_A,n_bar*n_bar,MPI_REAL,
     +             bcast_root, grid(ROW_COMM), ierr)
              call Local_matrix_multiply(temp_A, local_B,
     +             local_C, n_bar)
          endif
          call MPI_SENDRECV_REPLACE(local_B, n_bar*n_bar,
     +         MPI_REAL,
     +         dest, 0, source, 0, grid(COL_COMM), status, ierr)
 100  continue
C
      return
      end
C
C *******************************************************
C  Read and distribute matrix:
C      foreach global row of the matrix,
C          foreach grid column
C              read a block of n_bar floats on process 0
C              and send them to the appropriate process.
C
      subroutine Read_matrix(prompt, local_A, grid, n, Order)
      integer                  MAX
      parameter               ( MAX=1000 )
      character *10            prompt
      integer                  Order
      real                     local_A(Order* Order)
      integer                  n
C grid array representation of each subscript
      integer              P, COMM, ROW_COMM, COL_COMM, Q
      integer              MY_ROW, MY_COL, MYRANK
      parameter            (P=1, COMM = 2, ROW_COMM = 3,
     +                      COL_COMM = 4, Q = 5,
     +                      MY_ROW=6, MY_COL=7, MYRANK=8)
      integer              grid(8)
      INCLUDE        'mpif.h'
      integer        ierr
      integer        mat_row, mat_col
      integer        grid_row, grid_col
      integer        dest
      integer        coords(0:1)
      real           temp( MAX )
C
      integer   status(MPI_STATUS_SIZE)
      data   dest/ 0/

      if (grid(MYRANK) .EQ. 0)  then
          print *, prompt, '(One element per line)'
          do 100 mat_row = 1, n
              grid_row = (mat_row-1)/Order
              coords(0) = grid_row
              do 200 grid_col = 1, grid(Q)
                  coords(1) = grid_col - 1
                  call MPI_CART_RANK(grid(COMM),
     +                              coords,dest,ierr)
                  if (dest .EQ. 0)  then
C                   do 300 mat_col =1, Order
                    read *,
     +              (local_A((mat_row-1)*Order+mat_col),
     +               mat_col = 1, Order)
C 300                continue
                  else
C                      do 400 mat_col = 1, Order
                       read *,(temp(mat_col), mat_col =1,Order)
C 400                  continue
                      call MPI_SEND(temp,Order,MPI_REAL,
     +                      dest, 0,grid(COMM), ierr)
                  endif
 200          continue
 100      continue
      else
          do 500 mat_row = 1, Order
               call MPI_RECV(local_A(1+(mat_row-1)*Order),
     +              Order, MPI_REAL,
     +              0, 0, grid(COMM),  status, ierr)
 500      continue
      endif
C
      return
      end
C
C
C *******************************************************
      subroutine Print_matrix(title, local_A, grid, n, Order)
      integer              MAX
      parameter            ( MAX=1000 )
      character *14 title
      integer       Order
      real          local_A(Order *Order)
      integer       n
C grid array representation of each subscript
      integer              P, COMM, ROW_COMM, COL_COMM, Q
      integer              MY_ROW, MY_COL, MYRANK
      parameter            (P=1, COMM = 2, ROW_COMM = 3,
     +                      COL_COMM = 4, Q = 5,
     +                      MY_ROW=6, MY_COL=7, MYRANK=8)
      integer       grid(8)
      INCLUDE       'mpif.h'
      integer        ierr
      integer        mat_row, mat_col
      integer        grid_row, grid_col
      integer        source
      integer        coords(0:1)
      real           temp(MAX)
      real           printrow(MAX)
      integer        cnt
      integer        status(MPI_STATUS_SIZE)
C
      if (grid(MYRANK) .EQ. 0)  then
          print *, title
          do 100 mat_row = 1, n
              cnt = 0
              grid_row = (mat_row-1)/Order
              coords(0) = grid_row
              do 200 grid_col =1, grid(Q)
                 coords(1) = grid_col-1
                 call MPI_CART_RANK(grid(COMM),coords,
     +                        source, ierr)
                 if (source .EQ. 0)  then
                    do 300 mat_col = 1, Order
                        printrow(cnt+mat_col) =
     +                     local_A((mat_row-1)*Order+mat_col)
 300                continue
                    cnt = cnt + Order
                 else
                     call MPI_RECV(temp, Order, MPI_REAL,
     +                     source, 0,grid(COMM),  status, ierr)
                     do 350  mat_col = 1, Order
                          printrow(cnt+mat_col)= temp(mat_col)
 350                 continue
                     cnt = cnt + Order
                 endif
 200          continue
              print 400, (printrow(mat_col), mat_col = 1,n)
 400          format (' ',1000F10.2)
 100      continue
      else
          do 410 mat_row = 1,Order
              call MPI_SEND(local_A(1+ (mat_row-1)*Order ),
     +                  Order, MPI_REAL , 0, 0, grid(COMM), ierr)
 410      continue
      endif
C
      return
      end
C
C
C *******************************************************
      subroutine Set_to_zero(local_A, Order)
      integer              Order
      real                 local_A(Order*Order)

C
      integer i, j
C
      do 100 i = 1, Order
          do 200 j = 1,Order
               local_A((i-1)*j) = 0.0
 200      continue
 100  continue
C
      return
      end
C *******************************************************
      subroutine Local_matrix_multiply(local_A,
     +                   local_B, local_C, Order)
      integer           Order
      real  local_A(Order* Order)
      real  local_B(Order* Order)
      real  local_C(Order* Order)
C
      integer i, j, k
C
      do 100 i = 1, Order
          do 200 j =1,  Order
              do 300 k = 1, Order
                local_C( (i-1)* Order + j) =
     +                  local_C((i-1)*Order +j) +
     +                  local_A((i-1)*Order + k) *
     +                  local_B((k-1)*Order + j)
 300          continue
 200      continue
 100  continue
C
      return
      end
C


module point_module
  !! Point type and associated functions

  type point
    !! A point on a two dimensional plane
    real :: x
    !! 'x' coordinate
    real :: y
    !! 'y' coordinate
  end type

  interface operator (+)
    !! Overload '+' operator for adding points
    module procedure point_add
  end interface

  interface operator (-)
    !! Overloard '0' operator for subtracting points
    module procedure point_negative
    module procedure point_subtract
  end interface

contains

  function point_add(p1, p2) result(p3)
    !! Add two point objects
    type(point), intent(in) :: p1, p2
    type(point) :: p3
    p3%x = p1%x + p2%x
    p3%y = p1%y + p2%y
  end function

  function point_negative(p1) result(p2)
    !! Get the negative value of a point
    type(point), intent(in) :: p1
    type(point) :: p2
    p2%x = -p1%x
    p2%y = -p1%y
  end function

  function point_subtract(p1, p2) result(p3)
    !! Subtract two points
    type(point), intent(in) :: p1, p2
    type(point) :: p3
    p3 = p1 + (-p2)
  end function

end module

program example
  use, intrinsic :: iso_fortran_env, only: ou=>output_unit
  use point_module

  type(point) :: a = point(1,2)
  type(point) :: b = point(2,4)
  type(point) :: c

  c = a + b
  write(ou,'(g0)') c%x, c%y
  c = -c
  write(ou,'(g0)') c%x, c%y
  c = b - a
  write(ou,'(g0)') c%x, c%y
end program


      FUNCTION PartonX (IPRTN, X, Q)
C
C   Given the parton distribution function in the array Upd in
C   COMMON / CtqPar1 / , this routine fetches u(fl, x, q) at any value of
C   x and q using Mth-order polynomial interpolation for x and Ln(Q/Lambda).
C
      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
C
      PARAMETER (MXX = 105, MXQ = 25, MXF = 6)
      PARAMETER (MXPQX = (MXF *2 +2) * MXQ * MXX)
      PARAMETER (M= 2, M1 = M + 1)
C
      Logical First
      Common
     > / CtqPar1 / Al, XV(0:MXX), QL(0:MXQ), UPD(MXPQX)
     > / CtqPar2 / Nx, Nt, NfMx
     > / XQrange / Qini, Qmax, Xmin
C
      Dimension Fq(M1), Df(M1)

      Data First /.true./
      save First
C                                                 Work with Log (Q)
      QG  = LOG (Q/AL)

C                           Find lower end of interval containing X
      JL = -1
      JU = Nx+1
 11   If (JU-JL .GT. 1) Then
         JM = (JU+JL) / 2
         If (X .GT. XV(JM)) Then
            JL = JM
         Else
            JU = JM
         Endif
         Goto 11
      Endif

      Jx = JL - (M-1)/2
      If (X .lt. Xmin .and. First ) Then
         First = .false.
         Print '(A, 2(1pE12.4))',
     >     ' WARNING: X < Xmin, extrapolation used; X, Xmin =', X, Xmin
         If (Jx .LT. 0) Jx = 0
      Elseif (Jx .GT. Nx-M) Then
         Jx = Nx - M
      Endif
C                                    Find the interval where Q lies
      JL = -1
      JU = NT+1
 12   If (JU-JL .GT. 1) Then
         JM = (JU+JL) / 2
         If (QG .GT. QL(JM)) Then
            JL = JM
         Else
            JU = JM
         Endif
         Goto 12
      Endif

      Jq = JL - (M-1)/2
      If (Jq .LT. 0) Then
         Jq = 0
         If (Q .lt. Qini)  Print '(A, 2(1pE12.4))',
     >     ' WARNING: Q < Qini, extrapolation used; Q, Qini =', Q, Qini
      Elseif (Jq .GT. Nt-M) Then
         Jq = Nt - M
         If (Q .gt. Qmax)  Print '(A, 2(1pE12.4))',
     >     ' WARNING: Q > Qmax, extrapolation used; Q, Qmax =', Q, Qmax
      Endif

      If (Iprtn .GE. 3) Then
         Ip = - Iprtn
      Else
         Ip = Iprtn
      EndIf
C                             Find the off-set in the linear array Upd
      JFL = Ip + NfMx
      J0  = (JFL * (NT+1) + Jq) * (NX+1) + Jx
C
C                                           Now interpolate in x for M1 Q's
      Do 21 Iq = 1, M1
         J1 = J0 + (Nx+1)*(Iq-1) + 1
         Call Polint (XV(Jx), Upd(J1), M1, X, Fq(Iq), Df(Iq))
 21   Continue
C                                          Finish off by interpolating in Q
      Call Polint (QL(Jq), Fq(1), M1, QG, Ftmp, Ddf)

      PartonX = Ftmp
C
      RETURN
C                        ****************************
      END


      SUBROUTINE CALAVB2 (ISTL_)
C
C **  SUBROUTINE CALAV CALCULATES VERTICAL VISCOSITY AND DIFFUSIVITY
C **  USING GLAPERIN ET AL'S MODIFICATION OF THE MELLOR-YAMADA MODEL
C **  (NOTE AV, AB, AND AQ ARE ACTUALLY DIVIDED BY H)
C **  IF ISGA=1 VALUES ARE GEOMETRIC AVERAGES WITH THE PREVIOUS VALUES
C CHANGE RECORD
C
      USE GLOBAL

	IMPLICIT NONE
C
      !REAL*8 HPD(LCM),DMLD(LCM,KCM),BD(LCM,KCM),DZIGD(KCM)
      !REAL*8 CTURBB1D(LCM,KCM),CTURBB2D(LCM,KCM),QQD(LCM,KCM)
      !REAL*8 CTURBD,CTURB2BD,GPD
      !REAL*8 RIQMIN,RAVBTMP,DELBTMP,RITMP,BFUN,RIQ
      !REAL*8 TMPVAL,TMPVAL1,SBTOP,SVTOP,TMPVAL2,SVTOP2,SVBOT
      !REAL*8 SFAV,SFAB,SBBOT,TMPVAL3
      !REAL*8 ATURB1,ATURB2,TURBC1
      !REAL*8 AVTMP,ABTMP

      REAL*8 RIQMIN,DELBTMP,RITMP,BFUN,RIQ
      REAL*8 TMPVAL,TMPVAL1,SBTOP,SVTOP,TMPVAL2,SVTOP2,SVBOT
      REAL*8 SFAV,SFAB,SBBOT,TMPVAL3
      REAL*8 ATURB1,ATURB2,TURBC1
      REAL AVTMP,ABTMP,AQTMP
C
      INTEGER K,L,LS,ISTL_
C
      DATA ATURB1,ATURB2,TURBC1/0.92,0.74,0.08/
C
C   SHTOP    =      0.4939
C   SHBOT    =     34.6764
C   SMTOP1   =      0.3933
C   SMTOP2   =      7.8464
C   SMBOT1   =     34.6764
C   SMBOT2   =      6.1272
C   RLIMIT   =      0.0233
C   SHMIN    =      0.0934
C   SMMIN    =      0.1099
C   SHMAX    =      5.2073
C   SMMAX    =      4.9639
C
      RIQMIN=-0.023
C
      DO K=1,KS
        DO L=2,LA
          CTURBB1(L,K)=CTURB
          CTURBB2(L,K)=CTURB2B   ! PMC ONLY NEEDS TO BE ASSIGNED ONCE SINCE NEVER CHANGED
        ENDDO
      ENDDO
C
      DO K=1,KS    ! PMC SKIP IF BSC.LE.1.E-6
        DO L=2,LA
          DELBTMP=(B(L,K+1)-B(L,K))*DZIG(K)
          RITMP=-GP*HP(L)*DELBTMP/QQ(L,K)
          IF(RITMP.GT.0.)THEN
            RIQ=DML(L,K)*DML(L,K)*RITMP
            BFUN=EXP(-3.11*RIQ)
            CTURBB1(L,K)=CTURB/(BFUN+1.E-12)

            ! *** Original Code
            IF(BBT(L,K).GT.0.)THEN   ! *** PMC BBT is never set, so this is never used
              TMPVAL=DELBTMP*DELBTMP/(RITMP*BBT(L,K))
              CTURBB2(L,K)=CTURB2B/(1.+0.61*(1.-BFUN)*TMPVAL)
            ENDIF
          ENDIF
        ENDDO
      ENDDO

      DO K=1,KS
        DO L=2,LA
          RIQ=-GP*HP(L)*DML(L,K)*DML(L,K)*DZIG(K)
     &            *(B(L,K+1)-B(L,K))/QQ(L,K)
          RIQ=MAX(RIQ,RIQMIN)
          TMPVAL1=1.-( 6.*ATURB1/CTURBB1(L,K) )
          SBTOP=ATURB2*TMPVAL1
          SBBOT=3.*ATURB2*( 6.*ATURB1+CTURBB2(L,K) )
          SVTOP=ATURB1*( TMPVAL1-3.*TURBC1)
          TMPVAL2=TMPVAL1*( CTURBB2(L,K)-3.*ATURB2 )
          TMPVAL3=-3.*TURBC1*( CTURBB2(L,K)+6.*ATURB1)
          SVTOP2=3.*ATURB2*(TMPVAL2+TMPVAL3)/SVTOP
          SVBOT=9.*ATURB1*ATURB2
          SFAV=SVTOP*(1.+SVTOP2*RIQ)/((1.+SVBOT*RIQ)*(1.+SBBOT*RIQ))
          SFAB=SBTOP/(1.+SBBOT*RIQ)
          ABTMP=AVCON*SFAB*DML(L,K)*HP(L)*QQSQR(L,K)+ABO
          AVTMP=AVCON*SFAV*DML(L,K)*HP(L)*QQSQR(L,K)+AVO
C
          IF(ISFAVB.EQ.0)THEN
            AV(L,K)=AVTMP*HPI(L)
            AB(L,K)=SCB(L)*ABTMP*HPI(L)
          ELSEIF(ISFAVB.EQ.1)THEN
            AV(L,K)=0.5*(AV(L,K)+AVTMP*HPI(L))
            AB(L,K)=SCB(L)*0.5*(AB(L,K)+ABTMP*HPI(L))
          ELSEIF(ISFAVB.EQ.2)THEN
            AV(L,K)=SQRT(AV(L,K)*AVTMP*HPI(L))
            AB(L,K)=SCB(L)*SQRT(AB(L,K)*ABTMP*HPI(L))
          ENDIF
        ENDDO
      ENDDO

      IF(ISLOG.GE.1)THEN
        AVMAX=AVO
        ABMAX=ABO
        AVMIN=10.
        ABMIN=10.
        DO K=1,KS
          DO L=2,LA
            AVMAX=MAX(AVMAX,AV(L,K))
            ABMAX=MAX(ABMAX,AB(L,K))
            AVMIN=MIN(AVMIN,AV(L,K))
            ABMIN=MIN(ABMIN,AB(L,K))
          ENDDO
        ENDDO
      ENDIF

      ! *** NOW APPLY MAXIMUM, IF REQURIED
      IF(ISAVBMX.GE.1)THEN
        DO K=1,KS
          DO L=2,LA
            AVTMP=AVMX*HPI(L)
            ABTMP=ABMX*HPI(L)
            AV(L,K)=MIN(AV(L,K),AVTMP)
            AB(L,K)=MIN(AB(L,K),ABTMP)
          ENDDO
        ENDDO
      ENDIF

      DO K=1,KS
        DO L=2,LA
          LS=LSC(L)
          AVUI(L,K)=2./(AV(L,K)+AV(LWEST(L),K))
          AVVI(L,K)=2./(AV(L,K)+AV(LS,K))
        ENDDO
      ENDDO

      IF(ISTL_.EQ.3)THEN
        DO K=2,KS
          DO L=2,LA
            AQ(L,K)=0.205*(AV(L,K-1)+AV(L,K))
          ENDDO
        ENDDO
        DO L=2,LA
          AQ(L,1)=0.205*AV(L,1)
          AQ(L,KC)=0.205*AV(L,KS)
        ENDDO
      ELSE
        DO K=2,KS
          DO L=2,LA
            AQTMP=0.205*(AV(L,K-1)+AV(L,K))
            AQ(L,K)=AQTMP
          ENDDO
        ENDDO
        DO L=2,LA
          AQTMP=0.205*AV(L,1)
          AQ(L,1)=AQTMP
          AQTMP=0.205*AV(L,KS)
          AQ(L,KC)=AQTMP
        ENDDO
      ENDIF

      RETURN
      END


module m_MagneticField
  use m_Useful
  implicit none
  private
!
  public :: computeB
!
contains
!
  subroutine computeB (cxz)
    character (len=k_mw), parameter :: myname = "computeB"
    type (cxzType), intent (inout) :: cxz
!
    real (k_pr) :: rc (1:3), r, sina, cosa, rot (1:3, 1:3), rm (1:3), rcp (1:3), invrot (1:3, 1:3), a (1:3), b (1:3), mag (1:3), &
   & xa, gB (1:3), length
    integer :: i, j, k, m
!
    do j = 1, cxz%nframes
! compute the centre of the ring
      rc = 0.0_k_pr
      do i = 1, cxz%nring
        rc (1) = rc (1) + cxz%frames(j)%x(i)
        rc (2) = rc (2) + cxz%frames(j)%y(i)
        rc (3) = rc (3) + cxz%frames(j)%z(i)
      end do
      rc = rc / real (cxz%nring, k_pr)
      gB = 0.0_k_pr
      do i = 1, cxz%nring
! determine the rotation angle for each bond
! we start by computing the middle of the bond
        a (1) = cxz%frames(j)%x(i)
        a (2) = cxz%frames(j)%y(i)
        a (3) = cxz%frames(j)%z(i)
        b (1) = cxz%frames(j)%x(i+1)
        b (2) = cxz%frames(j)%y(i+1)
        b (3) = cxz%frames(j)%z(i+1)
        length = norm (b-a)
        sina = (a(1)-b(1)) / length
        cosa = (b(2)-a(2)) / length
        call Buildrotz (rot, cosa,-sina)
! matrix rot S'=rotS
        call Buildrotz (invrot, cosa, sina)
! matrix invrot S=rotS'
        rcp = matmul (rot, rc)
        a = matmul (rot, a)
        b = matmul (rot, b)
        xa = a (2)
        r = a (1)
        call localB (mag, rcp, xa, length, r, cxz%frames(j)%bondCurrent(i)*k_mju0/(4.0_k_pr*k_pi))
        gB = gB + matmul (invrot, mag)
      end do
      cxz%frames(j)%b = gB * k_B2tesla
!
    end do
  end subroutine computeB
!
!> \brief builds the rotation matrix around z
!> \author Alin M Elena
!> \date 18/08/2008, 10:41
!> \param rot the rotation matrix
!> \param ca real cos(alpha)
!> \param sa real sin(alpha)
!> \remarks \f[
!> R_z(\alpha)=\left(
!> \begin{array}{ccc}
!> \cos \alpha & -\sin \alpha & 0 \\\\
!> \sin \alpha & \cos \alpha & 0 \\\\
!> 0 & 0 & 1 \\\\
!> \end{array}
!> \right)
!> \f]
  subroutine Buildrotz (rot, ca, sa)
    character (len=*), parameter :: myname = "Buildrotz"
    real (k_pr), intent (inout) :: rot (:, :)
    real (k_pr), intent (in) :: ca, sa
!
    rot = 0.0_k_pr
    rot (1, 1) = ca
    rot (1, 2) = - sa
    rot (1, 3) = 0.0_k_pr
    rot (2, 1) = sa
    rot (2, 2) = ca
    rot (2, 3) = 0.0_k_pr
    rot (3, 1) = 0.0_k_pr
    rot (3, 2) = 0.0_k_pr
    rot (3, 3) = 1.0_k_pr
!
  end subroutine Buildrotz
!
  subroutine localB (b, r, a, length, xr, pre)
    character (len=*), parameter :: myname = "localB"
    real (k_pr), intent (inout) :: b (:)
    real (k_pr), intent (in) :: r (:), a, xr, pre, length
    real (k_pr) :: d, h
!
    d = Sqrt ((r(1)-xr)*(r(1)-xr)+r(3)*r(3))
    h = ((a+length-r(2))/Sqrt(d*d+(a+length-r(2))*(a+length-r(2)))-(a-r(2))/Sqrt(d*d+(a-r(2))*(a-r(2)))) / (d*d)
    b (2) = 0.0_k_pr
    b (1) = pre * h * r (3)
    b (3) = - pre * h * (r(1)-xr)
!
  end subroutine localB
!
!
!
!
end module m_MagneticField


      SUBROUTINE CFE2AO (TPOSE,V1,V2,V3,ZB)
C*******
C     CFE2AO IS A DOUBLE PRECISION ROUTINE WHICH PERFORMS THE OPERATION
C     (A) OR (A)-TRANSPOSE FOR THE COMPLEX FEER METHOD. THIS OPERATION
C     IS CALLED THE EIGENMATRIX MULTIPLICATION.
C*******
C     DEFINITION OF INPUT AND OUTPUT PARAMETERS
C*******
C     TPOSE    = .FALSE. --- PERFORM OPERATION (A)
C              = .TRUE.  --- PERFORM OPERATION (A)-TRANSPOSE
C     V1       = INPUT  VECTOR
C     V2       = OUTPUT VECTOR
C     V3       = INPUT WORKING SPACE (FOR INTERNAL USE)
C     ZB       = INPUT GINO BUFFER
C*******
      DOUBLE PRECISION  V1(1)    ,V2(1)    ,V3(1)    ,LAMBDA
      LOGICAL           TPOSE(1) ,NO B     ,QPR
      DIMENSION         ZB(1)
      COMMON  /FEERAA/  IK(7)    ,IM(7)    ,IB(7)    ,DUMAA(117)
     2                 ,MCBLMB(7)
      COMMON  /FEERXC/  LAMBDA(2),DUM01(2) ,NORD     ,IDIAG
     2                 ,EPSDUM(2),NORTHO   ,NORD2    ,NORD4
     3                 ,NORDP1   ,DUM02(2) ,NO B     ,DUM03(4)
     4                 ,QPR
      COMMON  /SYSTEM/  KSYS     ,NOUT
C*******
      IF (QPR) WRITE (NOUT,8881) TPOSE
 8881 FORMAT(1H0,12HENTER CFE2AO,8X,11HTRANSPOSE =,L2)
      IF (TPOSE(1)) GO TO 50
C*******
C     PERFORM OPERATION (A)  = EIGENMATRIX MULTIPLICATION
C*******
      IF ( NO B ) GO TO 30
C*******
C     MULTIPLY LOWER HALF OF INPUT VECTOR BY MASS MATRIX
C*******
      CALL CFE2MY (TPOSE(1),V1(NORDP1),V3(1),IM(1),ZB(1))
      IF (QPR) WRITE (NOUT,8882) (V3(I),I=1,NORD)
 8882 FORMAT(3H --,32(4H----),/(1H ,6D21.13))
C*******
C     MULTIPLY UPPER HALF OF INPUT VECTOR BY -(LAMBDA*M+B)
C*******
      CALL CFE2MY (TPOSE(1),V1(1),V3(NORDP1),MCBLMB(1),ZB(1))
      IF (QPR) WRITE (NOUT,8882) (V3(I),I=NORDP1,NORD2)
C*******
C     CALCULATE RIGHT-HAND SIDE OF SWEEP EQUATION
C*******
      DO 10  I = 1,NORD
      J = NORD+I
   10 V2(I) = -V3(I) + V3(J)
      IF (QPR) WRITE (NOUT,8882) (V2(I),I=1,NORD)
C*******
C     PERFORM FORWARD AND BACKWARD SWEEPS
C     (GENERATES UPPER HALF OF OUTPUT VECTOR)
C*******
      CALL CF2FBS (TPOSE(1),V2(1),ZB(1))
      IF (QPR) WRITE (NOUT,8882) (V2(I),I=1,NORD)
C*******
C     COMPUTE LOWER HALF OF OUTPUT VECTOR
C*******
      DO 20  I = 1,NORD,2
      J = I+1
      NI = NORD+I
      NJ = NI+1
      V2(NI) = V1(I) + LAMBDA(1)*V2(I) - LAMBDA(2)*V2(J)
   20 V2(NJ) = V1(J) + LAMBDA(1)*V2(J) + LAMBDA(2)*V2(I)
      IF (QPR) WRITE (NOUT,8882) (V2(I),I=NORDP1,NORD2)
      GO TO 200
C*******
C     DAMPING MATRIX ABSENT
C*******
C     MULTIPLY INPUT VECTOR BY MASS MATRIX
C*******
   30 CALL CFE2MY (TPOSE(1),V1(1),V2(1),IM(1),ZB(1))
      DO 40  I = 1,NORD2
   40 V2(I) = -V2(I)
      IF (QPR) WRITE (NOUT,8882) (V2(I),I=1,NORD2)
C*******
C     PERFORM FORWARD AND BACKWARD SWEEPS
C*******
      CALL CF2FBS (TPOSE(1),V2(1),ZB(1))
      IF (QPR) WRITE (NOUT,8882) (V2(I),I=1,NORD2)
      GO TO 200
C*******
C     PERFORM OPERATION (A)-TRANSPOSE  = TRANSPOSED EIGENMATRIX
C                                                   MULTIPLICATION
C*******
   50 IF ( NO B ) GO TO 90
C*******
C     CALCULATE RIGHT-HAND SIDE OF SWEEP EQUATION
C*******
      DO 60  I = NORDP1,NORD2,2
      J = I+1
      NI = I-NORD
      NJ = NI+1
      V3(I) = V1(NI) + LAMBDA(1)*V1(I) - LAMBDA(2)*V1(J)
   60 V3(J) = V1(NJ) + LAMBDA(1)*V1(J) + LAMBDA(2)*V1(I)
      IF (QPR) WRITE (NOUT,8882) (V3(I),I=NORDP1,NORD2)
C*******
C     PERFORM BACKWARD AND FORWARD SWEEPS
C*******
      CALL CF2FBS (TPOSE(1),V3(NORDP1),ZB(1))
      IF (QPR) WRITE (NOUT,8882) (V3(I),I=NORDP1,NORD2)
C*******
C     MULTIPLY SWEEP OUTPUT VECTOR BY -(LAMBDA*M+B)-TRANSPOSE
C*******
      CALL CFE2MY (TPOSE(1),V3(NORDP1),V3(1),MCBLMB(1),ZB(1))
      IF (QPR) WRITE (NOUT,8882) (V3(I),I=1,NORD)
C*******
C     COMPUTE UPPER HALF OF OUTPUT VECTOR
C*******
      DO 70  I = 1,NORD
      J = NORD+I
   70 V2(I) = V1(J) + V3(I)
      IF (QPR) WRITE (NOUT,8882) (V2(I),I=1,NORD)
C*******
C     MULTIPLY SWEEP OUTPUT VECTOR BY TRANSPOSED MASS MATRIX
C     (GENERATES NEGATIVE OF LOWER HALF OF OUTPUT VECTOR)
C*******
      CALL CFE2MY (TPOSE(1),V3(NORDP1),V2(NORDP1),IM(1),ZB(1))
      DO 80  I = NORDP1,NORD2
   80 V2(I) = -V2(I)
      IF (QPR) WRITE (NOUT,8882) (V2(I),I=NORDP1,NORD2)
      GO TO 200
C*******
C     DAMPING MATRIX ABSENT
C*******
C     PERFORM BACKWARD AND FORWARD SWEEPS
C*******
   90 DO 95  I = 1,NORD2
   95 V3(I) = V1(I)
      CALL CF2FBS (TPOSE(1),V3(1),ZB(1))
      IF (QPR) WRITE (NOUT,8882) (V3(I),I=1,NORD2)
C*******
C     MULTIPLY SWEEP OUTPUT VECTOR BY TRANSPOSED MASS MATRIX
C*******
      CALL CFE2MY (TPOSE(1),V3(1),V2(1),IM(1),ZB(1))
      DO 100  I = 1,NORD2
  100 V2(I) = -V2(I)
      IF (QPR) WRITE (NOUT,8882) (V2(I),I=1,NORD2)
  200 RETURN
      END


program whole_array_get
  implicit none

  integer,allocatable :: x1(:)[:],y1(:)
  integer,allocatable :: x2(:,:)[:],y2(:,:)
  integer,allocatable :: x3(:,:,:)[:],y3(:,:,:)
  integer,parameter   :: n = 10
  integer :: me,np,i,j,k

  me = this_image()
  np = num_images()

  allocate(x1(n)[*],y1(n))

  x1 = me
  y1 = 0

  sync all

  if(me == 1) then
     y1 = x1(:)[me+1]
     if(any(y1 /= 2)) then
        error stop 'Test 1 fails'
     end if
  end if

  deallocate(x1)
  allocate(x2(1:n,0:n-1)[*],y2(n,n))

  x2 = me
  y1 = 0; y2 = 0

  sync all
  if(me == 1) then
     y2 = x2(:,:)[np]
     if(any(y2 /= np)) then
        error stop 'Test 2 fails'
     end if
  end if

  sync all

  x2(:,n/2) = x2(:,n/2) + n/2

  sync all

  if(me == 1) then
     y1 = x2(:,n/2)[me+1]
     if(any(y1 /= 2+n/2)) then
        error stop 'Test 3 fails'
     end if
  end if

  deallocate(y1,x2,y2)
  allocate(x3(0:n-1,1:n,-1:n-2)[*],y3(n,n,n))

  x3 = me; y3 = 0

  sync all

  if(me == 1) then
     y3 = x3(:,:,:)[me+1]
     if(any(y3 /= me+1)) then
        error stop 'Test 4 fails'
     end if
  endif

  sync all

  x3(:,:,n/2) = me + n/2
  y3 = 0

  sync all

  if(me == 1) then
     y3(:,n/2,:) = x3(:,:,n/2)[me+1]
     if(any(y3(:,n/2,:) /= me+1+n/2)) then
        error stop 'Test 5 fails'
     end if
  endif

  if(me == 1) write(*,*) 'Test passed.'

end program whole_array_get


      DOUBLE PRECISION FUNCTION DVMAX(N,DX)
*     .. Scalar Arguments ..
      INTEGER N
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION DX(*)
*     ..
*
*  Purpose
*  =======
**
*     Return the maximum element in a vector.
*     FORTRAN-90 has an intrinsic for this,
*     but not FORTRAN-77 (and not in BLAS).
*     Alex Stivala 05July2008.
*     $Id: dvmax.F 2969 2009-11-22 01:29:39Z astivala $
*
*     .. Parameters ..
      DOUBLE PRECISION NEGINF
      PARAMETER (NEGINF=-1.79769d+308)
*     .. Local Scalars ..
      INTEGER I
      DOUBLE PRECISION MAXVAL
*     ..
*
      MAXVAL = NEGINF
      DO 10 I = 1,N
         IF (DX(I) .GT. MAXVAL) THEN
            MAXVAL = DX(I)
         ENDIF
   10 CONTINUE
      DVMAX = MAXVAL
      RETURN
      END


      SUBROUTINE proma1(a,b,c,n1,n2,n3)
!********************************************************************
!
!***THIS ROUTINE EVALUATES A MATRIX PRODUCT
!
!           A(I,J) = B(I,K) * C(K,J)    A = B * C
!
!********************************************************************
      IMPLICIT NONE

      INTEGER (kind=4),INTENT(IN) :: n1,n2,n3
      REAL (kind=8),INTENT(IN) :: b(n1,n3), c(n3,n2)
      REAL (kind=8),INTENT(OUT):: a(n1,n2)

      a = MATMUL(b,c)
      RETURN

      END SUBROUTINE proma1


! { dg-do run }
! { dg-require-effective-target fortran_large_real }
! Check that the random_seed for real(10) exists and that
! real(8) and real(10) random number generators
! return the same sequence of values.
! Mostly copied from random_2.f90
program random_3
  integer,parameter :: k = selected_real_kind (precision (0.0_8) + 1)

  integer, dimension(:), allocatable :: seed
  real(kind=8), dimension(10) :: r8
  real(kind=k), dimension(10) :: r10
  real, parameter :: delta = 1.d-10
  integer n

  ! Run the test only if real(10) is available. With the current
  ! xorshift1024* PRNG the real(16) generator uses two uint64_t values
  ! for every real(16) value generated, and hence the sequences won't
  ! be the same as with real(4,8,10).
  if (k == 10) then
     call random_seed (size=n)
     allocate (seed(n))
     call random_seed (get=seed)
     ! Test both array valued and scalar routines.
     call random_number(r8)
     call random_number (r8(10))

     ! Reset the seed and get the real(8) values.
     call random_seed (put=seed)
     call random_number(r10)
     call random_number (r10(10))

     if (any ((r8 - r10) .gt. delta)) call abort
  end if
end program random_3


program aocday1

implicit none

real :: mass, fuel_sum, total_fuel_sum
real, dimension(:), allocatable :: masses
integer :: i

masses = read_file("input")

fuel_sum = 0
total_fuel_sum = 0
do i = 1, size(masses)
    mass = masses(i)
    fuel_sum = fuel_sum + fuel(mass)
    total_fuel_sum = total_fuel_sum + total_fuel(mass)
end do

write(*,*) fuel_sum
write(*,*) total_fuel_sum

contains

function read_file(fname) result(xs)
    character(len=*), intent(in) :: fname
    real, dimension(:), allocatable :: xs
    real :: x
    integer, parameter :: file_unit = 10
    integer :: stat
    allocate(xs(0))
    open(unit=file_unit, file=fname)
    do
        read(file_unit, fmt=*, iostat=stat) x
        if (stat /= 0) exit
        xs = [xs, x]
    end do
    close(file_unit)
end function read_file

real function fuel(mass)
    real :: mass
    fuel = max(0, floor(mass / 3) - 2)
end function fuel

real function total_fuel(mass)
    real :: mass
    total_fuel = 0
    do while (mass > 0)
        mass = fuel(mass)
        total_fuel = total_fuel + mass
    end do
end function total_fuel

end program aocday1