      PROGRAM pole2vel

      IMPLICIT none
      INTEGER i
      CHARACTER*80 ifile,ofile
      INTEGER p
      REAL*8 pole(3),pxyz(3)
      INTEGER STAMAX,nsta
      PARAMETER (STAMAX=1000)
      REAL*8 sta(STAMAX,2)
      REAL*8 vel(STAMAX,3)
      INTEGER fun

C Get command line arguments
      call gcmdln(ifile,ofile,pole,p)
C      print *,'IFILE ',ifile
C      print *,'OFILE ',ofile
C      print *,'POLE ',pole(1),pole(2),pole(3)
C      print *,'PRINT ',p

C Convert Euler pole to XYZ components
      call lalomag2xyz(pxyz,pole)
C      print *,'POLE ',pxyz(1),pxyz(2),pxyz(3)

C Read station locations
      call readsta(ifile,sta,nsta)
C      print *,'NSTA ',nsta
C      do 101 i = 1,nsta
C          print *,i,sta(i,1),sta(i,2)
C  101 continue

C Compute NEZ velocity at stations
      call calcvel(sta,nsta,pxyz,vel)
C      do 102 i = 1,nsta
C          print *,i,vel(i,1),vel(i,2),vel(i,3)
C  102 continue

      if (p.eq.1.or.ofile.eq.'none') then
          fun = 6
      else
          fun = 11
          open(unit=fun,file=ofile,status='unknown')
      endif
      do 110 i = 1,nsta
          write(fun,9999) sta(i,1),sta(i,2),vel(i,1),vel(i,2),vel(i,3)
  110 continue
 9999 format(2F10.4,3F10.2)

      END

C----------------------------------------------------------------------C

      SUBROUTINE readsta(ifile,sta,nsta)
      IMPLICIT none
      INTEGER STAMAX,nsta
      PARAMETER (STAMAX=1000)
      CHARACTER*80 ifile
      REAL*8 sta(STAMAX,2)
      INTEGER funit
      if (ifile.eq.'stdin') then
          funit = 5
      else
          funit = 21
          open(unit=funit,file=ifile,status='old')
      endif
      nsta = 1
  210 read(funit,*,end=211) sta(nsta,1),sta(nsta,2)
          nsta = nsta + 1
          goto 210
  211 continue
      nsta = nsta - 1
      if(funit.eq.21)close(funit)
      RETURN
      END

C----------------------------------------------------------------------C

      SUBROUTINE lalomag2xyz(pxyz,pole)
      IMPLICIT none
      REAL*8 pi,d2r
      PARAMETER (pi=4.0d0*atan(1.0d0),d2r=pi/180.0d0)
      REAL*8 pole(3),pxyz(3)
      pxyz(1) = pole(3)*dcos(pole(2)*d2r)*dcos(pole(1)*d2r)
      pxyz(2) = pole(3)*dcos(pole(2)*d2r)*dsin(pole(1)*d2r)
      pxyz(3) = pole(3)*dsin(pole(2)*d2r)
      RETURN
      END

C----------------------------------------------------------------------C

      SUBROUTINE calcvel(sta,nsta,pxyz,vel)
      IMPLICIT none
      REAL*8 pi,d2r
      PARAMETER (pi=4.0d0*atan(1.0d0),d2r=pi/180.0d0)
      INTEGER STAMAX,nsta
      PARAMETER (STAMAX=1000)
      REAL*8 sta(STAMAX,2),lo,la,stavec(3)
      REAL*8 pxyz(3),v(3),r(3),vel(STAMAX,3)
      INTEGER i
      do 301 i = 1,nsta
          stavec(1) = sta(i,1)
          stavec(2) = sta(i,2)
          stavec(3) = 1.0d0
          call lalomag2xyz(r,stavec)
          call cross(v,pxyz,r)
          lo = sta(i,1)*d2r
          la = sta(i,2)*d2r
          vel(i,2) = -(v(1)*dsin(la)*dcos(lo)+v(2)*dsin(la)*dsin(lo)
     1                                                  -v(3)*dcos(la))
          vel(i,1) =  -v(1)         *dsin(lo)+v(2)         *dcos(lo)
          vel(i,3) =   v(1)*dcos(la)*dcos(lo)+v(2)*dcos(la)*dsin(lo)
     1                                                   +v(3)*dsin(la)
          vel(i,1) = vel(i,1)*111.19d0
          vel(i,2) = vel(i,2)*111.19d0
  301 continue
      RETURN
      END

C----------------------------------------------------------------------C

      SUBROUTINE cross(ovect,v1,v2)
      IMPLICIT none
      REAL*8 ovect(3),v1(3),v2(3)

      ovect(1) = v1(2)*v2(3) - v1(3)*v2(2)
      ovect(2) = v1(3)*v2(1) - v1(1)*v2(3)
      ovect(3) = v1(1)*v2(2) - v1(2)*v2(1)

      RETURN
      END

C----------------------------------------------------------------------C

      SUBROUTINE usage(str)
      IMPLICIT none
      INTEGER lstr
      CHARACTER str*(*)
      if (str.ne.' ') then
          lstr = len(str)
          write(*,*) str(1:lstr)
          write(*,*)
      endif
      write(*,*)
     1 'Usage: pole2vel -pole LON LAT WVEL -sta STAFILE -vel VFILE -p',
     2                ' -h/-?'
      write(*,*)
     1 '  -pole LON LAT WVEL   Euler pole location and angular ',
     2                                               'velocity (deg/Ma)'
      write(*,*)
     1 '  -sta STAFILE         Locations to compute velocity (',
     2                                                  'takes "stdin")'
      write(*,*)
     1 '  -vel VFILE           Velocity (ENZ) at locations in STAFILE'
      write(*,*)
     1 '  -p                   Print to standard out instead of VFILE'
      write(*,*)
     1 '  -h/-?                Online help (this screen)'
      write(*,*)
      STOP
      END

C----------------------------------------------------------------------C

      SUBROUTINE gcmdln(ifile,ofile,pole,p)
      IMPLICIT none
      CHARACTER*80 tag,ifile,ofile
      INTEGER narg,i,p
      REAL*8 pole(3)
      ifile = 'none'
      ofile = 'none'
      pole(1) = 0.0d0
      pole(2) = 0.0d0
      pole(3) = 0.0d0
      p = 0
      narg = iargc()
      if (narg.eq.0) call usage('!! Error: no command line arguments')
      i = 0
  101 i = i + 1
      if (i.gt.narg) goto 102
          call getarg(i,tag)
          if (tag(1:5).eq.'-pole') then
              i = i + 1
              call getarg(i,tag)
              read(tag,'(BN,F10.0)')pole(1)
              i = i + 1
              call getarg(i,tag)
              read(tag,'(BN,F10.0)')pole(2)
              i = i + 1
              call getarg(i,tag)
              read(tag,'(BN,F10.0)')pole(3)
          elseif (tag(1:4).eq.'-sta') then
              i = i + 1
              call getarg(i,ifile)
          elseif (tag(1:4).eq.'-vel') then
              i = i + 1
              call getarg(i,ofile)
          elseif (tag(1:2).eq.'-p') then
              p = 1
          elseif (tag(1:2).eq.'-h'.or.tag(1:2).eq.'-?') then
              call usage('')
          else
              call usage('!! Error: no option'//tag)
          endif
      goto 101
  102 continue
      RETURN
      END


*DECK DAVINT
      SUBROUTINE DAVINT (X, Y, N, XLO, XUP, ANS, IERR)
C***BEGIN PROLOGUE  DAVINT
C***PURPOSE  Integrate a function tabulated at arbitrarily spaced
C            abscissas using overlapping parabolas.
C***LIBRARY   SLATEC
C***CATEGORY  H2A1B2
C***TYPE      DOUBLE PRECISION (AVINT-S, DAVINT-D)
C***KEYWORDS  INTEGRATION, QUADRATURE, TABULATED DATA
C***AUTHOR  Jones, R. E., (SNLA)
C***DESCRIPTION
C
C     Abstract
C         DAVINT integrates a function tabulated at arbitrarily spaced
C         abscissas.  The limits of integration need not coincide
C         with the tabulated abscissas.
C
C         A method of overlapping parabolas fitted to the data is used
C         provided that there are at least 3 abscissas between the
C         limits of integration.  DAVINT also handles two special cases.
C         If the limits of integration are equal, DAVINT returns a
C         result of zero regardless of the number of tabulated values.
C         If there are only two function values, DAVINT uses the
C         trapezoid rule.
C
C     Description of Parameters
C         The user must dimension all arrays appearing in the call list
C              X(N), Y(N)
C
C         Input--
C      X    - DOUBLE PRECISION array of abscissas, which must be in
C             increasing order.
C      Y    - DOUBLE PRECISION array of function values. i.e.,
C                Y(I)=FUNC(X(I))
C      N    - The integer number of function values supplied.
C                N .GE. 2 unless XLO = XUP.
C      XLO  - DOUBLE PRECISION lower limit of integration
C      XUP  - DOUBLE PRECISION upper limit of integration.  Must have
C              XLO.LE.XUP
C
C         Output--
C      ANS  - Double Precision computed approximate value of integral
C      IERR - A status code
C           --Normal Code
C                =1 Means the requested integration was performed.
C           --Abnormal Codes
C                =2 Means XUP was less than XLO.
C                =3 Means the number of X(I) between XLO and XUP
C                   (inclusive) was less than 3 and neither of the two
C                   special cases described in the abstract occurred.
C                   No integration was performed.
C                =4 Means the restriction X(I+1).GT.X(I) was violated.
C                =5 Means the number N of function values was .lt. 2.
C                   ANS is set to zero if IERR=2,3,4,or 5.
C
C    DAVINT is documented completely in SC-M-69-335
C    Original program from *Numerical Integration* by Davis & Rabinowitz
C    Adaptation and modifications by Rondall E Jones.
C
C***REFERENCES  R. E. Jones, Approximate integrator of functions
C                 tabulated at arbitrarily spaced abscissas,
C                 Report SC-M-69-335, Sandia Laboratories, 1969.
C***ROUTINES CALLED  XERMSG
C***REVISION HISTORY  (YYMMDD)
C   690901  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DAVINT
C
      INTEGER I, IERR, INLFT, INRT, ISTART, ISTOP, N
      DOUBLE PRECISION A, ANS, B, C, CA, CB, CC, FL, FR, R3, RP5,
     1     SLOPE, SUM, SYL, SYL2, SYL3, SYU, SYU2, SYU3, TERM1, TERM2,
     2     TERM3, X, X1, X12, X13, X2, X23, X3, XLO, XUP, Y
      DIMENSION X(*),Y(*)
C     BEGIN BLOCK PERMITTING ...EXITS TO 190
C        BEGIN BLOCK PERMITTING ...EXITS TO 180
C***FIRST EXECUTABLE STATEMENT  DAVINT
            IERR = 1
            ANS = 0.0D0
            IF (XLO .GT. XUP) GO TO 160
               IF (XLO .EQ. XUP) GO TO 150
                  IF (N .GE. 2) GO TO 10
                     IERR = 5
                     CALL XERMSG ('SLATEC', 'DAVINT',
     +                  'LESS THAN TWO FUNCTION VALUES WERE SUPPLIED.',
     +                  4, 1)
C     ...............EXIT
                     GO TO 190
   10             CONTINUE
                  DO 20 I = 2, N
C        ............EXIT
                     IF (X(I) .LE. X(I-1)) GO TO 180
C                 ...EXIT
                     IF (X(I) .GT. XUP) GO TO 30
   20             CONTINUE
   30             CONTINUE
                  IF (N .GE. 3) GO TO 40
C
C                    SPECIAL N=2 CASE
                     SLOPE = (Y(2) - Y(1))/(X(2) - X(1))
                     FL = Y(1) + SLOPE*(XLO - X(1))
                     FR = Y(2) + SLOPE*(XUP - X(2))
                     ANS = 0.5D0*(FL + FR)*(XUP - XLO)
C     ...............EXIT
                     GO TO 190
   40             CONTINUE
                  IF (X(N-2) .GE. XLO) GO TO 50
                     IERR = 3
                     CALL XERMSG ('SLATEC', 'DAVINT',
     +                  'THERE WERE LESS THAN THREE FUNCTION VALUES ' //
     +                  'BETWEEN THE LIMITS OF INTEGRATION.', 4, 1)
C     ...............EXIT
                     GO TO 190
   50             CONTINUE
                  IF (X(3) .LE. XUP) GO TO 60
                     IERR = 3
                     CALL XERMSG ('SLATEC', 'DAVINT',
     +                  'THERE WERE LESS THAN THREE FUNCTION VALUES ' //
     +                  'BETWEEN THE LIMITS OF INTEGRATION.', 4, 1)
C     ...............EXIT
                     GO TO 190
   60             CONTINUE
                  I = 1
   70             IF (X(I) .GE. XLO) GO TO 80
                     I = I + 1
                  GO TO 70
   80             CONTINUE
                  INLFT = I
                  I = N
   90             IF (X(I) .LE. XUP) GO TO 100
                     I = I - 1
                  GO TO 90
  100             CONTINUE
                  INRT = I
                  IF ((INRT - INLFT) .GE. 2) GO TO 110
                     IERR = 3
                     CALL XERMSG ('SLATEC', 'DAVINT',
     +                  'THERE WERE LESS THAN THREE FUNCTION VALUES ' //
     +                  'BETWEEN THE LIMITS OF INTEGRATION.', 4, 1)
C     ...............EXIT
                     GO TO 190
  110             CONTINUE
                  ISTART = INLFT
                  IF (INLFT .EQ. 1) ISTART = 2
                  ISTOP = INRT
                  IF (INRT .EQ. N) ISTOP = N - 1
C
                  R3 = 3.0D0
                  RP5 = 0.5D0
                  SUM = 0.0D0
                  SYL = XLO
                  SYL2 = SYL*SYL
                  SYL3 = SYL2*SYL
C
                  DO 140 I = ISTART, ISTOP
                     X1 = X(I-1)
                     X2 = X(I)
                     X3 = X(I+1)
                     X12 = X1 - X2
                     X13 = X1 - X3
                     X23 = X2 - X3
                     TERM1 = Y(I-1)/(X12*X13)
                     TERM2 = -Y(I)/(X12*X23)
                     TERM3 = Y(I+1)/(X13*X23)
                     A = TERM1 + TERM2 + TERM3
                     B = -(X2 + X3)*TERM1 - (X1 + X3)*TERM2
     1                   - (X1 + X2)*TERM3
                     C = X2*X3*TERM1 + X1*X3*TERM2 + X1*X2*TERM3
                     IF (I .GT. ISTART) GO TO 120
                        CA = A
                        CB = B
                        CC = C
                     GO TO 130
  120                CONTINUE
                        CA = 0.5D0*(A + CA)
                        CB = 0.5D0*(B + CB)
                        CC = 0.5D0*(C + CC)
  130                CONTINUE
                     SYU = X2
                     SYU2 = SYU*SYU
                     SYU3 = SYU2*SYU
                     SUM = SUM + CA*(SYU3 - SYL3)/R3
     1                     + CB*RP5*(SYU2 - SYL2) + CC*(SYU - SYL)
                     CA = A
                     CB = B
                     CC = C
                     SYL = SYU
                     SYL2 = SYU2
                     SYL3 = SYU3
  140             CONTINUE
                  SYU = XUP
                  ANS = SUM + CA*(SYU**3 - SYL3)/R3
     1                  + CB*RP5*(SYU**2 - SYL2) + CC*(SYU - SYL)
  150          CONTINUE
            GO TO 170
  160       CONTINUE
               IERR = 2
               CALL XERMSG ('SLATEC', 'DAVINT',
     +            'THE UPPER LIMIT OF INTEGRATION WAS NOT GREATER ' //
     +            'THAN THE LOWER LIMIT.', 4, 1)
  170       CONTINUE
C     ......EXIT
            GO TO 190
  180    CONTINUE
         IERR = 4
         CALL XERMSG ('SLATEC', 'DAVINT',
     +      'THE ABSCISSAS WERE NOT STRICTLY INCREASING.  MUST HAVE ' //
     +      'X(I-1) .LT. X(I) FOR ALL I.', 4, 1)
  190 CONTINUE
      RETURN
      END


 ! fortran   f90

 ! To use it with python, compile with f2py

SUBROUTINE recenter_positions(positions, masses, factors, positions_, nstep, nat)
    implicit none
    INTEGER, intent(in)                             ::  nstep, nat
    ! masses are the masses of the atoms, factors are an additional factor so that we can
    ! calculate the center of mass only for certain species
    REAL*8, intent(in), dimension(nat)              ::  masses
    INTEGER, intent(in), dimension(nat)             :: factors
    REAL*8, intent(in),  dimension(nstep, nat, 3)   :: positions
    REAL*8, intent(out), dimension(nstep, nat, 3)   :: positions_

    INTEGER                                         :: iat, istep, ipol
    REAL*8, dimension(nat)                          :: rel_masses
    REAL*8, dimension(3)                            :: com
    REAL*8                                          ::  M

    DO iat=1, nat
        rel_masses(iat) = DBLE(factors(iat)) * masses(iat)
    END DO

    M = sum(rel_masses)
    rel_masses(:) = rel_masses(:) / M
    DO istep=1, nstep
        com(1:3) = 0.D0
        DO iat=1, nat
            DO ipol=1, 3
                com(ipol) = com(ipol) + rel_masses(iat)*positions(istep, iat, ipol) ! / M
            END DO
        END DO

        DO iat=1, nat
            DO ipol=1, 3
                positions_(istep, iat, ipol) = positions(istep, iat, ipol)  - com(ipol)
            END DO
        END DO
    END DO
END SUBROUTINE recenter_positions

SUBROUTINE recenter_velocities(velocities, masses, factors, velocities_, nstep, nat)
    implicit none
    ! Make the center of mass velocity disappear
    INTEGER, intent(in)                             ::  nstep, nat
    REAL*8, intent(in), dimension(nat)              :: masses
    INTEGER, intent(in), dimension(nat)             :: factors
    REAL*8, intent(in),  dimension(nstep, nat, 3)   :: velocities
    REAL*8, intent(out), dimension(nstep, nat, 3)   :: velocities_
    INTEGER                                         :: iat, istep, ipol
    REAL*8, dimension(nat)                          :: rel_masses
    REAL*8, dimension(3)                            :: com
    REAL*8                                          :: M

    DO iat=1, nat
        rel_masses(iat) = DBLE(factors(iat)) * masses(iat)
    END DO

    M = sum(rel_masses)
    rel_masses(:) = rel_masses(:) / M

    DO istep=1, nstep
        com(1:3) = 0.D0
        DO iat=1, nat
            DO ipol=1, 3
                com(ipol) = com(ipol) + rel_masses(iat)*velocities(istep, iat, ipol)
            END DO
        END DO

        DO iat=1, nat
            DO ipol=1, 3
                velocities_(istep, iat, ipol) = velocities(istep, iat, ipol)  - com(ipol)
            END DO
        END DO
    END DO

END SUBROUTINE recenter_velocities

SUBROUTINE calculate_msd_specific_atoms(    &
        positions,                              &
        indices_of_interest,                    &
        msd,                                    &
        stepsize_t,                             &
        stepsize_tau,                           &
        block_length_dt,                        &
        nr_of_blocks,                           &
        nr_of_t,                                &
        nstep,                                  &
        nat,                                    &
        nat_of_interest                         &
    )

    ! Fastest routine, instead of manipulating the trajectories
    ! and passing only the trajectories of interest,
    ! pass the indices of interest (remember index counting starts at 1)
    ! and let fortran do the magic
    ! Faster (x2) because no array manipulation is necessary

    implicit none

    INTEGER, intent(in)         ::  nstep,  nat,            &   ! Number of timesteps, number of atoms
                                    nat_of_interest,        &   ! number of atoms of interest
                                    nr_of_blocks,           &   ! Nr of blocks to calculate
                                    block_length_dt,        &   ! block length in dt
                                    nr_of_t,                &   ! nr of times of t
                                    stepsize_t,             &   ! The stepsize, eg 10 to calculate every 10th time
                                    stepsize_tau              ! The inner stepsize

    REAL*8, intent(in),  dimension(nstep, nat, 3)           :: positions
    INTEGER, intent(in), dimension(nat_of_interest)         :: indices_of_interest
    REAL*8, intent(out), dimension(nr_of_blocks, nr_of_t)   :: msd

    ! Local variables:
    INTEGER                     ::  t, tau,                    &        ! Time variables
                                    iat, ipol,                  &        ! Atom count
                                    iat_of_interest,           &        ! Atom count in indices_of interest
                                    iblock                              ! block count
    REAL*8                      ::  msd_this_t !, M

    ! Loop over the block
    DO iblock = 1, nr_of_blocks
        ! Loop over time t
        DO t = 1, nr_of_t
            ! Calculate one value of msd for this t in this block
            ! based on the average over atoms and running window defined by tau
            msd_this_t = 0.0d0
            ! loop over atoms (remember this code only deals with single species
            DO iat_of_interest=1, nat_of_interest
                iat = indices_of_interest(iat_of_interest)
                ! Running average achieved by letting tau run through the whole block
                DO tau = (iblock -1)*block_length_dt+1, iblock*block_length_dt, stepsize_tau
                    DO ipol=1, 3
                        msd_this_t = msd_this_t + (positions(tau+stepsize_t*t, iat, ipol)-positions(tau, iat, ipol))**2
                    END DO
                END DO
            END DO
            msd(iblock, t) = msd_this_t
        END DO
    END DO
    msd(:,:) = msd(:, :) / DBLE(block_length_dt) / DBLE(nat_of_interest) * DBLE(stepsize_tau)  ! / DBLE(
end SUBROUTINE calculate_msd_specific_atoms

SUBROUTINE calculate_msd_specific_atoms_max_stats(    &
        positions,                              &
        indices_of_interest,                    &
        msd,                                    &
        stepsize_t,                             &
        stepsize_tau,                           &
        nr_of_t,                                &
        nstep,                                  &
        nat,                                    &
        nat_of_interest                         &
    )

    ! This subroutine does the same as calculate_msd_specific_atoms,
    ! but tries to maximize the statistics. It calculates a mean only,
    ! w/o blocking, but takes every datapoint for it's calculation!

    implicit none

    INTEGER, intent(in)         ::  nstep,  nat,            &   ! Number of timesteps, number of atoms
                                    nat_of_interest,        &   ! number of atoms of interest
                                    nr_of_t,                &   ! nr of times of t
                                    stepsize_t,             &   ! The stepsize, eg 10 to calculate every 10th time
                                    stepsize_tau                ! The inner stepsize

    REAL*8, intent(in),  dimension(nstep, nat, 3)           :: positions
    INTEGER, intent(in), dimension(nat_of_interest)         :: indices_of_interest
    REAL*8, intent(out), dimension(nr_of_t)   :: msd

    ! Local variables:
    INTEGER                     ::  t, tau,                    &        ! Time variables
                                    iat, ipol,                  &        ! Atom count
                                    iat_of_interest, &                      ! Atom count in indices_of interest
                                    icount

    REAL*8                      ::  msd_this_t, msd_this_t_tau_iat, fcount !, M

    ! Loop over time t. This here is the index that I will give,
    ! actual time is stepsize_t*t
    DO t = 1, nr_of_t
        ! Calculate one value of msd for this t in this block
        ! based on the average over atoms and running window defined by tau
        msd_this_t = 0.0D0
        icount = 1
        DO iat_of_interest=1, nat_of_interest
            iat = indices_of_interest(iat_of_interest)
            ! Running average achieved by letting tau run through the entire trajectory!
            DO tau = 1, nstep - t*stepsize_t
                msd_this_t_tau_iat = 0.0D0
                ! You do not mean over directions!
                DO ipol=1, 3
                    msd_this_t_tau_iat = msd_this_t_tau_iat + &
                      (positions(tau+stepsize_t*t, iat, ipol)-positions(tau, iat, ipol))**2
                END DO
                fcount = DBLE(icount)
                msd_this_t = (fcount - 1.0D0 ) / fcount * msd_this_t + &
                        msd_this_t_tau_iat / fcount
                icount = icount + 1

            END DO
        END DO
        msd(t) = msd_this_t
    END DO
    ! msd(:,:) = msd(:, :) / DBLE(nat_of_interest) * DBLE(stepsize_tau)  ! / DBLE(
end SUBROUTINE calculate_msd_specific_atoms_max_stats

SUBROUTINE get_com_positions(positions, masses, factors, positions_, nstep, nat)

    implicit none
    INTEGER, intent(in)                             ::  nstep, nat
    ! masses are the masses of the atoms, factors are an additional factor so that we can
    ! calculate the center of mass only for certain species
    REAL*8, intent(in), dimension(nat)              ::  masses
    INTEGER, intent(in), dimension(nat)             :: factors
    REAL*8, intent(in),  dimension(nstep, nat, 3)   :: positions
    REAL*8, intent(out), dimension(nstep, 1, 3)     :: positions_

    INTEGER                                         :: iat, istep, ipol
    REAL*8, dimension(nat)                          :: rel_masses
    REAL*8, dimension(3)                            :: com
    REAL*8                                          ::  M

    DO iat=1, nat
        rel_masses(iat) = DBLE(factors(iat)) * masses(iat)
    END DO

    M = sum(rel_masses)
    rel_masses(:) = rel_masses(:) / M
    DO istep=1, nstep
        com(1:3) = 0.D0
        DO iat=1, nat
            DO ipol=1, 3
                com(ipol) = com(ipol) + rel_masses(iat)*positions(istep, iat, ipol) ! / M
            END DO
        END DO
        positions_(istep, 1, 1:3) = com(1:3)
    END DO
END SUBROUTINE get_COM_positions

SUBROUTINE get_com_velocities(velocities, masses, factors, velocities_, nstep, nat)

    implicit none
    INTEGER, intent(in)                             ::  nstep, nat
    ! masses are the masses of the atoms, factors are an additional factor so that we can
    ! calculate the center of mass only for certain species
    REAL*8, intent(in), dimension(nat)              ::  masses
    INTEGER, intent(in), dimension(nat)             :: factors
    REAL*8, intent(in),  dimension(nstep, nat, 3)   :: velocities
    REAL*8, intent(out), dimension(nstep, 1, 3)     :: velocities_

    INTEGER                                         :: iat, istep, ipol
    REAL*8, dimension(nat)                          :: rel_masses
    REAL*8, dimension(3)                            :: com
    REAL*8                                          ::  M

    DO iat=1, nat
        rel_masses(iat) = DBLE(factors(iat)) * masses(iat)
    END DO

    M = sum(rel_masses)
    rel_masses(:) = rel_masses(:) / M
    DO istep=1, nstep
        com(1:3) = 0.D0
        DO iat=1, nat
            DO ipol=1, 3
                com(ipol) = com(ipol) + rel_masses(iat)*velocities(istep, iat, ipol) ! / M
            END DO
        END DO
        velocities_(istep, 1, 1:3) = com(1:3)
    END DO
END SUBROUTINE get_COM_velocities

SUBROUTINE calculate_msd_specific_atoms_decompose_d(    &
        positions,                              &
        indices_of_interest,                    &
        msd,                                    &
        stepsize,                               &
        stepsize_inner,                         &
        block_length_dt,                        &
        nr_of_blocks,                           &
        nr_of_t,                                &
        nstep,                                  &
        nat,                                    &
        nat_of_interest                         &
    )
    ! calculates the diffusion coefficient matrix by looping over ipol and jpol
    implicit none

    INTEGER, intent(in)         ::  nstep,  nat,            &   ! Number of timesteps, number of atoms
                                    nat_of_interest,        &   ! number of atoms of interest
                                    nr_of_blocks,           &   ! Nr of blocks to calculate
                                    block_length_dt,        &   ! block length in dt
                                    nr_of_t,                &   ! nr of times of t
                                    stepsize,               &   ! The stepsize, eg 10 to calculate every 10th time
                                    stepsize_inner              ! The inner stepsize

    REAL*8, intent(in),  dimension(nstep, nat, 3)           :: positions
    INTEGER, intent(in), dimension(nat_of_interest)         :: indices_of_interest
    REAL*8, intent(out), dimension(nr_of_blocks, nr_of_t,3,3) :: msd

    ! Local variables:
    INTEGER                     ::  t, tau,                    &        ! Time variables
                                    iat, ipol, jpol,           &        ! Atom count
                                    iat_of_interest,           &        ! Atom count in indices_of interest
                                    iblock                              ! block count
    REAL*8                      ::  msd_this_t !, M

    ! Loop over the block

    DO iblock = 1, nr_of_blocks
        ! Loop over time t
        DO t = 1, nr_of_t
            ! Calculate one value of msd for this t in this block
            ! based on the average over atoms and running window defined by tau
            DO ipol=1,3
                DO jpol=1,3
                    msd_this_t = 0.0d0
                    DO iat_of_interest=1, nat_of_interest
                        iat = indices_of_interest(iat_of_interest)
                        ! Running average achieved by letting tau run through the whole block
                        DO tau = (iblock -1)*block_length_dt+1, iblock*block_length_dt, stepsize_inner
                            msd_this_t = msd_this_t + &
                                (positions(tau+stepsize*t, iat, ipol)-positions(tau, iat, ipol))* &
                                (positions(tau+stepsize*t, iat, jpol)-positions(tau, iat, jpol))
                        END DO
                    END DO
                    msd(iblock, t, ipol, jpol) = msd_this_t
                END DO
            END DO

        END DO
    END DO
    msd(:,:,:,:) = msd(:, :,:, :) / DBLE(block_length_dt) / DBLE(nat_of_interest) * DBLE(stepsize_inner)  ! / DBLE(
end SUBROUTINE calculate_msd_specific_atoms_decompose_d

SUBROUTINE calculate_vaf_specific_atoms(        &
        velocities,                             &
        indices_of_interest,                    &
        vaf,                                    &
        stepsize,                               &
        stepsize_tau,                           &
        nr_of_t,                                &
        nr_of_blocks,                           &
        block_length_dt,                        &
        deltaT,                                 &
        integration_method,                     &
        nstep,                                  &
        nat,                                    &
        nat_of_interest,                        &
        vaf_integral                            &
    )

    ! Calcyulates the velocities from the positions and than the autocorrelation function
    ! Averaging over all atoms given by the incices of interest

    implicit none
    INTEGER, intent(in)         ::  nstep,  nat,            &   ! Number of timesteps, number of atoms
                                    nat_of_interest,        &   ! number of atoms of interest
                                    nr_of_t, nr_of_blocks,  &   ! nr of times of t
                                    stepsize,               &   ! The stepsize, eg 10 to calculate every 10th time
                                    stepsize_tau, block_length_dt     ! The stepsize for tau, eg 10 to calculate every 10th time
    CHARACTER*256, intent(in)        ::  integration_method
    ! THE ARRAYS:
    REAL*8, intent(in),  dimension(nstep, nat, 3)           :: velocities
    INTEGER, intent(in), dimension(nat_of_interest)         :: indices_of_interest
    REAL*8, intent(out), dimension(nr_of_blocks, nr_of_t)   :: vaf
    REAL*8, intent(out), dimension(nr_of_blocks, nr_of_t)   :: vaf_integral

    ! Local variables:
    INTEGER                     ::  t, tau,            &        ! Time variables
                                    iat, iblock,       &        ! Atom count
                                    iat_of_interest, ipol          ! Atom count in indices_of interest

    REAL*8                      ::  vaf_this_t, vaf_this_t_cumulated !, nr_of_samples_real
    REAL*8, intent(in)          ::  deltaT !, nr_of_samples_real
    INTEGER                     ::  n

    ! I having N blocks:
    DO iblock=1, nr_of_blocks
        ! My time goes from 0 to the time defined as t_end_vaf
        DO t = 0, nr_of_t - 1
            vaf_this_t_cumulated = 0.0d0
            n = 0
            DO iat_of_interest=1, nat_of_interest
                iat = indices_of_interest(iat_of_interest)
                DO tau = (iblock -1)*block_length_dt+1,iblock*block_length_dt, stepsize_tau
                   ! tau = (iblock -1)*block_length_dt+1,
                    vaf_this_t = 0.0d0
                    DO ipol=1, 3
                        vaf_this_t = vaf_this_t + velocities(tau+stepsize*t, iat, ipol)*velocities(tau, iat, ipol)
                    END DO
                    vaf_this_t_cumulated = ( DBLE(n)*vaf_this_t_cumulated + vaf_this_t ) / DBLE(n+1)
                    n = n+1
                END DO
            END DO

            ! vaf_this_t = vaf_this_t / DBLE(block_length_dt) / DBLE(nat_of_interest) / DBLE(stepsize_tau)

            vaf(iblock, t+1) = vaf_this_t_cumulated

            ! Using trapezoidal rule to estimate the integral,

            SELECT CASE ( integration_method )
                CASE ( 'trapezoid' )
                    IF ( t .eq. 0 ) THEN
                        vaf_integral(iblock, t+1) = 0.5 * deltaT * vaf_this_t_cumulated
                    ELSEIF ( t .eq. ( nr_of_t-1 ) ) THEN
                        vaf_integral(iblock, t+1) = 0.5 * deltaT * vaf_this_t_cumulated  + vaf_integral(iblock, t)
                    ELSE
                        vaf_integral(iblock, t+1) = deltaT * vaf_this_t_cumulated + vaf_integral(iblock, t)
                    ENDIF
                CASE ( 'trapezoid-simple' )
                    IF ( t .eq. 0 ) THEN
                        vaf_integral(iblock, t+1) = 0.0D0
                    ELSE
                        vaf_integral(iblock, t+1) = vaf_integral(iblock, t) + deltaT*0.5*(vaf(iblock, t+1) + vaf(iblock, t))
                    ENDIF

                CASE ( 'simpson' )
                    IF ( t .eq. 0 ) THEN
                        vaf_integral(iblock, t+1) =  deltaT / 3.0D0 * vaf_this_t_cumulated
                    ELSEIF ( t .eq. ( nr_of_t-1 ) ) THEN
                        vaf_integral(iblock, t+1) =  deltaT / 3.0D0 * vaf_this_t_cumulated+vaf_integral(iblock, t)
                    ELSEIF ( MOD(t, 2) .eq. 0 ) THEN
                        vaf_integral(iblock, t+1) =  4.0D0 * deltaT / 3.0D0 * vaf_this_t_cumulated+vaf_integral(iblock, t)
                    ELSEIF ( MOD(t, 2) .eq. 1 ) THEN
                        vaf_integral(iblock, t+1) =  2.0D0 * deltaT / 3.0D0 * vaf_this_t_cumulated+vaf_integral(iblock, t)
                    ENDIF

            END SELECT

            ! USING simpson's rule

        END DO
    END DO

END SUBROUTINE calculate_vaf_specific_atoms


      SUBROUTINE slPRCE (SYSTEM, EP0, EP1, RA, DC)
*+
*     - - - - - - -
*      P R C E
*     - - - - - - -
*
*  Precession - either FK4 (Bessel-Newcomb, pre IAU 1976) or
*  FK5 (Fricke, post IAU 1976) as required.
*
*  Given:
*     SYSTEM     char   precession to be applied: 'FK4' or 'FK5'
*     EP0,EP1    dp     starting and ending epoch
*     RA,DC      dp     RA,Dec, mean equator & equinox of epoch EP0
*
*  Returned:
*     RA,DC      dp     RA,Dec, mean equator & equinox of epoch EP1
*
*  Called:    slDA2P, slPRBN, slPREC, slDS2C,
*             slDMXV, slDC2S
*
*  Notes:
*
*     1)  Lowercase characters in SYSTEM are acceptable.
*
*     2)  The epochs are Besselian if SYSTEM='FK4' and Julian if 'FK5'.
*         For example, to precess coordinates in the old system from
*         equinox 1900.0 to 1950.0 the call would be:
*             CALL slPRCE ('FK4', 1900D0, 1950D0, RA, DC)
*
*     3)  This routine will NOT correctly convert between the old and
*         the new systems - for example conversion from B1950 to J2000.
*         For these purposes see slFK45, slFK54, slF45Z and
*         slF54Z.
*
*     4)  If an invalid SYSTEM is supplied, values of -99D0,-99D0 will
*         be returned for both RA and DC.
*
*  P.T.Wallace   Starlink   20 April 1990
*
*  Copyright (C) 1995 Rutherford Appleton Laboratory
*
*  License:
*    This program is free software; you can redistribute it and/or modify
*    it under the terms of the GNU General Public License as published by
*    the Free Software Foundation; either version 2 of the License, or
*    (at your option) any later version.
*
*    This program is distributed in the hope that it will be useful,
*    but WITHOUT ANY WARRANTY; without even the implied warranty of
*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
*    GNU General Public License for more details.
*
*    You should have received a copy of the GNU General Public License
*    along with this program (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
*    Boston, MA  02110-1301  USA
*
*  Copyright (C) 1995 Association of Universities for Research in Astronomy Inc.
*-

      IMPLICIT NONE

      CHARACTER SYSTEM*(*)
      DOUBLE PRECISION EP0,EP1,RA,DC

      DOUBLE PRECISION PM(3,3),V1(3),V2(3)
      CHARACTER SYSUC*3

      DOUBLE PRECISION slDA2P

*  Convert to uppercase and validate SYSTEM
      SYSUC=SYSTEM
      IF (SYSUC(1:1).EQ.'f') SYSUC(1:1)='F'
      IF (SYSUC(2:2).EQ.'k') SYSUC(2:2)='K'
      IF (SYSUC.NE.'FK4'.AND.SYSUC.NE.'FK5') THEN
         RA=-99D0
         DC=-99D0
      ELSE

*     Generate appropriate precession matrix
         IF (SYSUC.EQ.'FK4') THEN
            CALL slPRBN(EP0,EP1,PM)
         ELSE
            CALL slPREC(EP0,EP1,PM)
         END IF

*     Convert RA,Dec to x,y,z
         CALL slDS2C(RA,DC,V1)

*     Precess
         CALL slDMXV(PM,V1,V2)

*     Back to RA,Dec
         CALL slDC2S(V2,RA,DC)
         RA=slDA2P(RA)

      END IF

      END


! Module to define global variables used in 3d_sub.f90 (or 3d_strike.f90)
Module phy3d_module_non
public

integer, parameter :: DP0=kind(1.d0)
integer :: IDin, IDout,Iprofile,Lratio,Nab,nprocs,Nl,Nd,hd
integer :: nmv,nas,ncos,nnul,nsse
real (DP0), parameter :: pi = 3.14159265358979323
real (DP0), parameter :: xmu= 0.3d0, cs= 9.6d+7,xnu = 0.25d0, &
                         V0=3.2d+4,f0=0.6,eta=2.0*xmu/cs,  &
                         gamma=2.0/pi, &
                         p18 = 2.d0*pi/360.d0
real (DP0), parameter :: yrs=365.*24.*3600.d0, yrd=365.d0

real (DP0) :: tm1,tm2,tmday,tmelse,tmmidn,tmmult,Vpl

real (DP0), DIMENSION(:), ALLOCATABLE :: cca,ccb,seff,xLf
!real (DP0), DIMENSION(:,:,:), ALLOCATABLE :: fr
real (DP0), DIMENSION(:,:), ALLOCATABLE :: stiff
character(len=80) :: jobname,foldername,restartname,stiffname,profile
end module phy3d_module_non


      program prog
      dimension vals(4)
      vals(1) = 1.2
      vals(2) = vals(1)**2
      vals(3) = 2**vals(2)
      vals(4) = vals(2)**vals(3)
      write(6, '(4f5.2)') (vals(i), i=1,4)
      end


      SUBROUTINE hypdrv(s,y,dyds)
      REAL s
      COMPLEX y(2),dyds(2),aa,bb,cc,z0,dz,z
      COMMON /hypg/ aa,bb,cc,z0,dz
      z=z0+s*dz
      dyds(1)=y(2)*dz
      dyds(2)=((aa*bb)*y(1)-(cc-((aa+bb)+1.)*z)*y(2))*dz/(z*(1.-z))
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/hypdrv.for


C Copyright(C) 2009 Sandia Corporation. Under the terms of Contract
C DE-AC04-94AL85000 with Sandia Corporation, the U.S. Government retains
C certain rights in this software.
C
C Redistribution and use in source and binary forms, with or without
C modification, are permitted provided that the following conditions are
C met:
C
C     * Redistributions of source code must retain the above copyright
C       notice, this list of conditions and the following disclaimer.
C
C     * Redistributions in binary form must reproduce the above
C       copyright notice, this list of conditions and the following
C       disclaimer in the documentation and/or other materials provided
C       with the distribution.
C     * Neither the name of Sandia Corporation nor the names of its
C       contributors may be used to endorse or promote products derived
C       from this software without specific prior written permission.
C
C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
C "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
C LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
C A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
C OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
C SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
C LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
C DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
C THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
C (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
C OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

C $Log: gaussf.f,v $
C Revision 1.2  2009/03/25 12:36:44  gdsjaar
C Add copyright and license notice to all files.
C Permission to assert copyright has been granted; blot is now open source, BSD
C
C Revision 1.1  1994/04/07 20:01:23  gdsjaar
C Initial checkin of ACCESS/graphics/blotII2
C
c Revision 1.2  1990/12/14  08:50:56  gdsjaar
c Added RCS Id and Log to all files
c
C=======================================================================
      SUBROUTINE GAUSSF (IS3DIM, NLNKF, LINKF1, XN, YN, ZN,
     &   XGAUSS, YGAUSS, ZGAUSS)
C=======================================================================

C   --*** GAUSSF *** (DETOUR) Calculate gauss point for a face
C   --   Written by Amy Gilkey - revised 10/20/87
C   --
C   --GAUSSF calculates the 4 element gauss points given the coordinates
C   --of the 4 nodes.
C   --
C   --Parameters:
C   --   IS3DIM - IN - true iff 3D versus 2D
C   --   NLNKF - IN - the number of nodes per face; must be 4
C   --   LINKF1 - IN - the connectivity for the face
C   --   XN, YN, ZN - IN - the nodal coordinates
C   --   XGAUSS, YGAUSS, ZGAUSS - OUT - the gauss point coordinates

      PARAMETER (S = .577350269189626)

      LOGICAL IS3DIM
      INTEGER LINKF1(NLNKF)
      REAL XN(*), YN(*), ZN(*)
      REAL XGAUSS(4), YGAUSS(4), ZGAUSS(4)

      REAL WT(4,4)
      LOGICAL FIRST
      SAVE FIRST, WT
C      --FIRST - true iff first time in routine
C      --WT - the gauss point constants

      DATA FIRST /.TRUE./

      IF (FIRST) THEN
         FIRST = .FALSE.

C      --Determine gauss point constants

         DO 100 N = 1, 4
            IF (N .EQ. 1) THEN
               SI = -S
               TI = -S
            ELSE IF (N .EQ. 2) THEN
               SI = +S
               TI = -S
            ELSE IF (N .EQ. 3) THEN
               SI = +S
               TI = +S
            ELSE IF (N .EQ. 4) THEN
               SI = -S
               TI = +S
            END IF
            WT(1,N) = .25 * (1-SI) * (1-TI)
            WT(2,N) = .25 * (1+SI) * (1-TI)
            WT(3,N) = .25 * (1+SI) * (1+TI)
            WT(4,N) = .25 * (1-SI) * (1+TI)
  100    CONTINUE
      END IF

C   --Determine gauss point coordinates

      DO 110 N = 1, 4
         XGAUSS(N) = WT(1,N)*XN(LINKF1(1)) + WT(2,N)*XN(LINKF1(2))
     &      + WT(3,N)*XN(LINKF1(3)) + WT(4,N)*XN(LINKF1(4))
         YGAUSS(N) = WT(1,N)*YN(LINKF1(1)) + WT(2,N)*YN(LINKF1(2))
     &      + WT(3,N)*YN(LINKF1(3)) + WT(4,N)*YN(LINKF1(4))
         IF (IS3DIM) THEN
            ZGAUSS(N) = WT(1,N)*ZN(LINKF1(1)) + WT(2,N)*ZN(LINKF1(2))
     &         + WT(3,N)*ZN(LINKF1(3)) + WT(4,N)*ZN(LINKF1(4))
         END IF
  110 CONTINUE

      RETURN
      END


      SUBROUTINE UNITS
*
*
*       Initialization of units & scaling factors.
*       ------------------------------------------
*
      INCLUDE 'common6.h'
*
*
*       Define GM & PC in cgs units and #AU in pc (2008 IAU values).
      GM = 6.6743D-08*1.9884D+33
      PC = 3.0856776D+18
      AU = PC/1.4959787D+13  ! bug fix from D+12 4/7/11 (was OK in 2009).
*
*       Form scaling factors for binary periods A*SQRT(A/M) to yrs and days.
      YRS = (RBAR*AU)**1.5/SQRT(ZMBAR)
      DAYS = 365.24*YRS
*
*       Specify conversion factors for lengths to solar radii & AU.
      SU = PC/(AU*6.955D+10)*RBAR*AU
      RAU = RBAR*AU
*
*       Copy solar mass scaling to new variable (M = BODY*<M>).
      SMU = ZMBAR
*
*       Form time scale in seconds and velocity scale in km/sec.
      TSTAR = SQRT(PC/GM)*PC
      VSTAR = 1.0D-05*SQRT(GM/PC)
*
*       Convert time scale from units of seconds to million years.
      TSTAR = TSTAR/(3.15D+07*1.0D+06)
*
*       Ensure ZMBAR & RBAR > 0 (=0: assume <M>/Sun = 1, RBAR = 1 pc).
      IF (ZMBAR.LE.0.0D0) ZMBAR = FLOAT(N)/ZMASS
      IF (RBAR.LE.0.0D0) RBAR = 1.0
*
*       Scale to working units of RBAR in pc & ZMBAR in solar masses.
      TSTAR = TSTAR*SQRT(RBAR**3/(ZMASS*ZMBAR))
      VSTAR = VSTAR*SQRT(ZMASS*ZMBAR/RBAR)
*
*       Copy TSTAR to secondary time-scale factor.
      TSCALE = TSTAR
*
*       Physical scaling: X, M, V, T from RBAR*X, ZMBAR*M, VSTAR*V, TSTAR*T.
      if(rank.eq.0)
     &WRITE (6,10)  RBAR, ZMBAR, VSTAR, TSTAR, BODYM*ZMBAR, SU
   10 FORMAT (/,12X,'PHYSICAL SCALING:    R* =',F5.2,'  M* =',F8.1,
     &              '  V* =',F6.3,'  T* =',F6.3,'  <M> =',F5.2,
     &              '  SU =',1P,E8.1)
*
*       Define relevant parameter for the GR case (RZ = 6*<m>/c^2).
      IF (KZ(27).EQ.3.OR.KZ(28).GT.0) THEN
          CLIGHT = 3.0D+05/VSTAR
          RZ = 6.0*ZMASS/(FLOAT(N)*CLIGHT**2)
          if(rank.eq.0)
     &    WRITE (6,20)  VSTAR, CLIGHT, RZ
   20     FORMAT (/,12X,'GR SCALING:    V* =',1P,E10.2,'  C =',E10.2,
     &                                  '  RZ =',E10.2)
      END IF
*
      RETURN
*
      END


module general_tll2xy_mod
!$$$   module documentation block
!                .      .    .                                       .
! module:    generic_tll2xy_mod  generalized conversion from latlon to xy
!   prgmmr: parrish          org: np22                date: 2010-10-28
!
! abstract: This module contains generalized tll2xy and related routines to convert
!             earth lat lon coordinates to grid coordinates for an orthogonal
!             non-staggered grid for which the earth lat and lon is known for each grid point.
!            NOTE: all routines tested against same routines in gridmod, using region_lat, region_lon first,
!                then random x,y,ug,vg.  get exact match between gridmod routines and the corresponding
!                  general_ routines here.  See subroutine test1_general_ll2xy at end of this module.
!
! program history log:
!   2010-10-28  parrish - initial documentation
!   2013-01-23  parrish - modify so calls to ll2rpolar and rpolar2ll avoid type mismatch error
!                           when using WCOSS intel debug compile.
!
! subroutines included:
!   sub general_create_llxy_transform - initialize type(llxy_cons) for desired grid
!   sub general_tll2xy                - convert from lat-lon to grid coordinates for desired grid
!   sub general_txy2ll                - convert from grid coordinates to lat-lon for desired grid
!   sub general_rotate_wind_ll2xy     - rotate earth wind to grid wind for desired grid
!   sub general_rotate_wind_xy2ll     - rotate grid wind to earth wind for desired grid
!
! Variable Definitions:
!   def llxy_cons:                    - type variable which is used to make parameter set previously
!                                         hardwired in gridmod.f90 portable for arbitrary grids.
!
!
! attributes:
!   language: f90
!   machine:  ibm RS/6000 SP
!
!$$$ end documentation block

   use kinds, only: r_kind,i_kind,i_byte

   implicit none

! set default to private
   private
! set subroutines to public
   public :: general_create_llxy_transform
   public :: general_tll2xy
   public :: general_txy2ll
   public :: general_rotate_wind_ll2xy
   public :: general_rotate_wind_xy2ll
! set passed variables to public
   public :: llxy_cons

   type llxy_cons
! The following is for the generalized transform
      real(r_kind) rlon_min_dd,rlon_max_dd,rlat_min_dd,rlat_max_dd
      real(r_kind) pihalf,sign_pole,rlambda0
      real(r_kind) atilde_x,btilde_x,atilde_y,btilde_y
      real(r_kind) btilde_xinv,btilde_yinv
      integer(i_kind) nlon,nlat,nxtilde,nytilde
      integer(i_kind),pointer::i0_tilde(:,:) => NULL()
      integer(i_kind),pointer::j0_tilde(:,:) => NULL()
      integer(i_byte),pointer::ip_tilde(:,:) => NULL()
      integer(i_byte),pointer::jp_tilde(:,:) => NULL()
      real(r_kind),pointer::xtilde0(:,:) => NULL()
      real(r_kind),pointer::ytilde0(:,:) => NULL()
      real(r_kind),pointer::cos_beta_ref(:,:) => NULL()
      real(r_kind),pointer::sin_beta_ref(:,:) => NULL()
      real(r_kind),pointer::region_lat(:,:) => NULL()
      real(r_kind),pointer::region_lon(:,:) => NULL()
      logical:: lallocated = .false.

   end type llxy_cons

!  other declarations  ...

   contains

 subroutine general_create_llxy_transform(region_lat,region_lon,nlat,nlon,gt)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    general_create_llxy_transform
!   prgmmr:  parrish
!
! abstract:  copy routines from gridmod.f90 to make a general purpose module which allows
!     conversion of earth lat lons to grid coordinates for any non-staggered rectangular
!     orthogonal grid with known earth lat and lon of each grid point.
!     set up constants to allow conversion between earth lat lon and analysis grid units.
!     There is no need to specify details of the analysis grid projection.  All that is required
!     is the earth latitude and longitude in radians of each analysis grid point.
!
! program history log:
!   2010-10-28  parrish - initial documentation
!   2012-11-28  tong - added gt%lallocated=.true. after arrays of gt are allocated and
!                      removed the duplicate allocation of gt%region_lat,gt%region_lon
!                      at the begining
!
!   input argument list:
!    glats       - earth latitudes of each grid point for desired grid.
!    glons       - earth longitudes of each grid point for desired grid.
!
!   output argument list:
!    gt          - variable of type llxy_cons, which contains all information needed for
!                   conversion between earth lat lon and this grid grid units.
!
! attributes:
!   language: f90
!   machine:
!
!$$$ end documentation block

  use kinds, only: r_kind,i_kind
  use constants, only: zero,one,half,pi
  implicit none

  integer(i_kind),intent(in   ) :: nlat,nlon
  real(r_kind)   ,intent(in   ) :: region_lat(nlat,nlon),region_lon(nlat,nlon)
  type(llxy_cons),intent(inout) :: gt

  real(r_kind),parameter:: rbig =1.0e30_r_kind
  real(r_kind) xbar_min,xbar_max,ybar_min,ybar_max
  real(r_kind) clon,slon,r_of_lat,xbar,ybar
  integer(i_kind) i,j,istart0,iend,iinc,itemp,ilast,jlast
  real(r_kind) glats(nlon,nlat),glons(nlon,nlat)
  real(r_kind),allocatable:: clata(:,:),slata(:,:),clona(:,:),slona(:,:)
  real(r_kind) clat0,slat0,clon0,slon0
  real(r_kind) clat_m1,slat_m1,clon_m1,slon_m1
  real(r_kind) clat_p1,slat_p1,clon_p1,slon_p1
  real(r_kind) x,y,z,xt,yt,zt,xb,yb,zb
  real(r_kind) rlonb_m1,clonb_m1,slonb_m1
  real(r_kind) rlonb_p1,clonb_p1,slonb_p1
  real(r_kind) crot,srot

  do j=1,nlon
     do i=1,nlat
        glats(j,i)=region_lat(i,j)
        glons(j,i)=region_lon(i,j)
     end do
  end do
  gt%pihalf=half*pi
  gt%nlon=nlon
  gt%nlat=nlat
  gt%rlon_min_dd=one
  gt%rlat_min_dd=one
  gt%rlon_max_dd=nlon
  gt%rlat_max_dd=nlat

!  define xtilde, ytilde grid, transform

!      glons,glats are lons, lats of input grid points of dimension nlon,nlat
  call general_get_xytilde_domain(gt,gt%nlon,gt%nlat,glons,glats,gt%nxtilde,gt%nytilde, &
                   xbar_min,xbar_max,ybar_min,ybar_max)
  if(gt%lallocated) then
     deallocate(gt%i0_tilde,gt%j0_tilde,gt%ip_tilde,gt%jp_tilde,gt%xtilde0,gt%ytilde0)
     deallocate(gt%cos_beta_ref,gt%sin_beta_ref,gt%region_lat,gt%region_lon)
     gt%lallocated=.false.
  end if
  allocate(gt%i0_tilde(gt%nxtilde,gt%nytilde),gt%j0_tilde(gt%nxtilde,gt%nytilde))
  allocate(gt%ip_tilde(gt%nxtilde,gt%nytilde),gt%jp_tilde(gt%nxtilde,gt%nytilde))
  allocate(gt%xtilde0(gt%nlon,gt%nlat),gt%ytilde0(gt%nlon,gt%nlat))
  allocate(gt%cos_beta_ref(gt%nlon,gt%nlat),gt%sin_beta_ref(gt%nlon,gt%nlat))
  allocate(gt%region_lat(gt%nlat,gt%nlon),gt%region_lon(gt%nlat,gt%nlon))

  gt%lallocated=.true.

  do j=1,nlon
     do i=1,nlat
        gt%region_lat(i,j)=region_lat(i,j)
        gt%region_lon(i,j)=region_lon(i,j)
     end do
  end do

! define atilde_x, btilde_x, atilde_y, btilde_y

  gt%btilde_x   =(gt%nxtilde -one     )/(xbar_max-xbar_min)
  gt%btilde_xinv=(xbar_max-xbar_min)/(gt%nxtilde -one     )
  gt%atilde_x   =one-gt%btilde_x*xbar_min
  gt%btilde_y   =(gt%nytilde -one     )/(ybar_max-ybar_min)
  gt%btilde_yinv=(ybar_max-ybar_min)/(gt%nytilde -one     )
  gt%atilde_y   =one-gt%btilde_y*ybar_min

! define xtilde0,ytilde0
  do j=1,gt%nlat
     do i=1,gt%nlon
        r_of_lat=gt%pihalf+gt%sign_pole*glats(i,j)
        clon=cos(glons(i,j)+gt%rlambda0)
        slon=sin(glons(i,j)+gt%rlambda0)
        xbar=r_of_lat*clon
        ybar=r_of_lat*slon
        gt%xtilde0(i,j)=gt%atilde_x+gt%btilde_x*xbar
        gt%ytilde0(i,j)=gt%atilde_y+gt%btilde_y*ybar
     end do
  end do

!  now get i0_tilde, j0_tilde, ip_tilde,jp_tilde
  ilast=1 ; jlast=1
  istart0=gt%nxtilde
  iend=1
  iinc=-1
  do j=1,gt%nytilde
     itemp=istart0
     istart0=iend
     iend=itemp
     iinc=-iinc
     ybar=j
     do i=istart0,iend,iinc
        xbar=i
        call general_nearest_3(ilast,jlast,gt%i0_tilde(i,j),gt%j0_tilde(i,j), &
                       gt%ip_tilde(i,j),gt%jp_tilde(i,j),xbar,ybar,gt%nlon,gt%nlat,gt%xtilde0,gt%ytilde0)
     end do
  end do

!   new, more accurate and robust computation of cos_beta_ref and sin_beta_ref which is independent
!     of sign_pole and works for any orientation of grid on sphere (only restriction for now is that
!     x-y coordinate of analysis grid is right handed).
  allocate(clata(gt%nlon,gt%nlat),slata(gt%nlon,gt%nlat),clona(gt%nlon,gt%nlat),slona(gt%nlon,gt%nlat))
  do j=1,gt%nlat
     do i=1,gt%nlon
        clata(i,j)=cos(glats(i,j))
        slata(i,j)=sin(glats(i,j))
        clona(i,j)=cos(glons(i,j))
        slona(i,j)=sin(glons(i,j))
     end do
  end do
  do j=1,gt%nlat
     do i=2,gt%nlon-1

!     do all interior lon points to 2nd order accuracy

!   transform so pole is at rlat0,rlon0 and 0 meridian is tangent to earth latitude at rlat0,rlon0.

        clat0=clata(i,j) ; slat0=slata(i,j) ; clon0=clona(i,j) ; slon0=slona(i,j)

!    now obtain new coordinates for m1 and p1 points.

        clat_m1=clata(i-1,j) ; slat_m1=slata(i-1,j) ; clon_m1=clona(i-1,j) ; slon_m1=slona(i-1,j)
        clat_p1=clata(i+1,j) ; slat_p1=slata(i+1,j) ; clon_p1=clona(i+1,j) ; slon_p1=slona(i+1,j)

        x=clat_m1*clon_m1 ; y=clat_m1*slon_m1 ; z=slat_m1
        xt=x*clon0+y*slon0 ; yt=-x*slon0+y*clon0 ; zt=z
        yb=zt*clat0-xt*slat0
        xb=yt
        zb=xt*clat0+zt*slat0

        rlonb_m1=atan2(-yb,-xb)   !  the minus signs here are so line for m1 is directed same
        clonb_m1=cos(rlonb_m1)
        slonb_m1=sin(rlonb_m1)

        x=clat_p1*clon_p1 ; y=clat_p1*slon_p1 ; z=slat_p1
        xt=x*clon0+y*slon0 ; yt=-x*slon0+y*clon0 ; zt=z
        yb=zt*clat0-xt*slat0
        xb=yt
        zb=xt*clat0+zt*slat0
        rlonb_p1=atan2(yb,xb)
        clonb_p1=cos(rlonb_p1)
        slonb_p1=sin(rlonb_p1)
        crot=half*(clonb_m1+clonb_p1)
        srot=half*(slonb_m1+slonb_p1)
        gt%cos_beta_ref(i,j)=crot*clon0-srot*slon0
        gt%sin_beta_ref(i,j)=srot*clon0+crot*slon0
     end do
!               now do i=1 and i=gt%nlon at 1st order accuracy
     i=1

!   transform so pole is at rlat0,rlon0 and 0 meridian is tangent to earth latitude at rlat0,rlon0.

        clat0=clata(i,j) ; slat0=slata(i,j) ; clon0=clona(i,j) ; slon0=slona(i,j)
!    now obtain new coordinates for m1 and p1 points.

        clat_p1=clata(i+1,j) ; slat_p1=slata(i+1,j) ; clon_p1=clona(i+1,j) ; slon_p1=slona(i+1,j)

        x=clat_p1*clon_p1 ; y=clat_p1*slon_p1 ; z=slat_p1
        xt=x*clon0+y*slon0 ; yt=-x*slon0+y*clon0 ; zt=z
        yb=zt*clat0-xt*slat0
        xb=yt
        zb=xt*clat0+zt*slat0
        rlonb_p1=atan2(yb,xb)
        clonb_p1=cos(rlonb_p1)
        slonb_p1=sin(rlonb_p1)
        crot=clonb_p1
        srot=slonb_p1
        gt%cos_beta_ref(i,j)=crot*clon0-srot*slon0
        gt%sin_beta_ref(i,j)=srot*clon0+crot*slon0

     i=gt%nlon

!   transform so pole is at rlat0,rlon0 and 0 meridian is tangent to earth latitude at rlat0,rlon0.

        clat0=clata(i,j) ; slat0=slata(i,j) ; clon0=clona(i,j) ; slon0=slona(i,j)

!    now obtain new coordinates for m1 and p1 points.

        clat_m1=clata(i-1,j) ; slat_m1=slata(i-1,j) ; clon_m1=clona(i-1,j) ; slon_m1=slona(i-1,j)

        x=clat_m1*clon_m1 ; y=clat_m1*slon_m1 ; z=slat_m1
        xt=x*clon0+y*slon0 ; yt=-x*slon0+y*clon0 ; zt=z
        yb=zt*clat0-xt*slat0
        xb=yt
        zb=xt*clat0+zt*slat0

        rlonb_m1=atan2(-yb,-xb)   !  the minus signs here are so line for m1 is directed same
        clonb_m1=cos(rlonb_m1)
        slonb_m1=sin(rlonb_m1)

        crot=clonb_m1
        srot=slonb_m1
        gt%cos_beta_ref(i,j)=crot*clon0-srot*slon0
        gt%sin_beta_ref(i,j)=srot*clon0+crot*slon0
  end do
  deallocate(clata,slata,clona,slona)

end subroutine general_create_llxy_transform

subroutine general_tll2xy(gt,rlon,rlat,x,y,outside)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    general_tll2xy
!   prgmmr:  parrish
!
! abstract:  copy routines from gridmod.f90 to make a general purpose module which allows
!     conversion of earth lat lons to grid coordinates for any non-staggered rectangular
!     orthogonal grid with known earth lat and lon of each grid point.
!     general_tll2xy converts earth lon-lat to x-y grid units of a
!           general regional rectangular domain.  Also, decides if
!           point is inside this domain.  As a result, there is
!           no restriction on type of horizontal coordinate for
!           a regional run, other than that it not have periodicity
!           or polar singularities.
!           This is done by first converting rlon, rlat to an
!           intermediate coordinate xtilde,ytilde, which has
!           precomputed pointers and constants for final conversion
!           to the desired x,y via 3 point inverse interpolation.
!           All of the information needed is derived from arrays
!           specifying earth latitude and longitude of every point
!           on the input grid.  Currently, the input x-y grid that
!           this is based on must be non-staggered.  This restriction
!           will eventually be lifted so we can run directly from
!           model grids that are staggered without first resorting
!           to interpolation of the guess to a non-staggered grid.
!
! program history log:
!   2010-10-28  parrish - initial documentation
!
!   input argument list:
!    gt          - type(llxy_cons) contains transform information to convert lat,lon to grid units x,y
!    rlon,rlat   - earth longitude and latitude (radians)
!
!   output argument list:
!    x,y         - grid coordinates in grid units.
!    outside     - if .false., then point is inside grid domain
!                    otherwise point is outside domain.
!
! attributes:
!   language: f90
!   machine:
!
!$$$ end documentation block

    use kinds, only: r_kind,i_kind
    use constants, only: one
    implicit none

    type(llxy_cons),intent(in) :: gt
    real(r_kind),intent(in   ) :: rlon
    real(r_kind),intent(in   ) :: rlat
    real(r_kind),intent(  out) :: x
    real(r_kind),intent(  out) :: y
    logical     ,intent(  out) :: outside

    real(r_kind) clon,slon,r_of_lat,xtilde,ytilde
    real(r_kind) dtilde,etilde
    real(r_kind) d1tilde,d2tilde,e1tilde,e2tilde,detinv
    integer(i_kind) itilde,jtilde
    integer(i_kind) i0,j0,ip,jp

!   first compute xtilde, ytilde

    clon=cos(rlon+gt%rlambda0)
    slon=sin(rlon+gt%rlambda0)
    r_of_lat=gt%pihalf+gt%sign_pole*rlat

    xtilde=gt%atilde_x+gt%btilde_x*r_of_lat*clon
    ytilde=gt%atilde_y+gt%btilde_y*r_of_lat*slon

!  next get interpolation information

    itilde=max(1,min(nint(xtilde),gt%nxtilde))
    jtilde=max(1,min(nint(ytilde),gt%nytilde))

    i0     =   gt%i0_tilde(itilde,jtilde)
    j0     =   gt%j0_tilde(itilde,jtilde)
    ip     =i0+gt%ip_tilde(itilde,jtilde)
    jp     =j0+gt%jp_tilde(itilde,jtilde)
    dtilde =xtilde-gt%xtilde0(i0,j0)
    etilde =ytilde-gt%ytilde0(i0,j0)
    d1tilde=(gt%xtilde0(ip,j0)-gt%xtilde0(i0,j0))*(ip-i0)
    d2tilde=(gt%xtilde0(i0,jp)-gt%xtilde0(i0,j0))*(jp-j0)
    e1tilde=(gt%ytilde0(ip,j0)-gt%ytilde0(i0,j0))*(ip-i0)
    e2tilde=(gt%ytilde0(i0,jp)-gt%ytilde0(i0,j0))*(jp-j0)
    detinv =one/(d1tilde*e2tilde-d2tilde*e1tilde)
    x = i0+detinv*(e2tilde*dtilde-d2tilde*etilde)
    y = j0+detinv*(d1tilde*etilde-e1tilde*dtilde)

    outside=x < gt%rlon_min_dd .or. x > gt%rlon_max_dd .or. &
            y < gt%rlat_min_dd .or. y > gt%rlat_max_dd

end subroutine general_tll2xy

subroutine general_txy2ll(gt,x,y,rlon,rlat)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    general_txy2ll
!   prgmmr:  parrish
!
! abstract: convert x-y grid units to earth lat-lon coordinates
!
! program history log:
!   2010-10-28 parrish - initial documentation
!
!   input argument list:
!    gt          - type(llxy_cons) contains transform information to convert x,y to lat,lon
!    x,y         - grid coordinates in grid units.
!
!   output argument list:
!    rlon,rlat   - earth longitude and latitude (radians)
!
! attributes:
!   language: f90
!   machine:
!
!$$$ end documentation block

    use kinds, only: r_kind,i_kind
    use constants, only: one
    implicit none

    type(llxy_cons),intent(in) :: gt
    real(r_kind),intent(in   ) :: x
    real(r_kind),intent(in   ) :: y
    real(r_kind),intent(  out) :: rlon
    real(r_kind),intent(  out) :: rlat

    real(r_kind) r_of_lat,xtilde,ytilde
    real(r_kind) dtilde,etilde,xbar,ybar
    real(r_kind) d1tilde,d2tilde,e1tilde,e2tilde
    integer(i_kind) i0,j0,ip,jp

    i0=nint(x)
    j0=nint(y)
    i0=max(1,min(i0,gt%nlon))
    j0=max(1,min(j0,gt%nlat))
    ip=i0+nint(sign(one,x-i0))
    jp=j0+nint(sign(one,y-j0))
    if(ip<1) then
       i0=2
       ip=1
    end if
    if(jp<1) then
       j0=2
       jp=1
    end if
    if(ip>gt%nlon) then
       i0=gt%nlon-1
       ip=gt%nlon
    end if
    if(jp>gt%nlat) then
       j0=gt%nlat-1
       jp=gt%nlat
    end if
    d1tilde=(gt%xtilde0(ip,j0)-gt%xtilde0(i0,j0))*(ip-i0)
    d2tilde=(gt%xtilde0(i0,jp)-gt%xtilde0(i0,j0))*(jp-j0)
    e1tilde=(gt%ytilde0(ip,j0)-gt%ytilde0(i0,j0))*(ip-i0)
    e2tilde=(gt%ytilde0(i0,jp)-gt%ytilde0(i0,j0))*(jp-j0)
    dtilde =d1tilde*(x-i0) +d2tilde*(y-j0)
    etilde =e1tilde*(x-i0) +e2tilde*(y-j0)
    xtilde =dtilde         +gt%xtilde0(i0,j0)
    ytilde =etilde         +gt%ytilde0(i0,j0)

    xbar=(xtilde-gt%atilde_x)*gt%btilde_xinv
    ybar=(ytilde-gt%atilde_y)*gt%btilde_yinv
    r_of_lat=sqrt(xbar**2+ybar**2)
    rlat=(r_of_lat-gt%pihalf)*gt%sign_pole
    rlon=atan2(ybar,xbar)-gt%rlambda0

end subroutine general_txy2ll

subroutine general_nearest_3(ilast,jlast,i0,j0,ip,jp,x,y,nx0,ny0,x0,y0)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    nearest_3
!   prgmmr:
!
! abstract: find closest 3 points to (x,y) on grid defined by x0,y0
!
! program history log:
!   2009-08-04  lueken - added subprogram doc block
!
!   input argument list:
!    ilast,jlast
!    nx0,ny0
!    x,y
!    x0,y0
!
!   output argument list:
!    ilast,jlast
!    i0,j0
!    ip,jp
!
! attributes:
!   language: f90
!   machine:
!
!$$$ end documentation block

  use kinds, only: r_kind,i_kind,i_byte
  implicit none

  integer(i_kind),intent(inout) :: ilast,jlast
  integer(i_kind),intent(  out) :: i0,j0
  integer(i_byte),intent(  out) :: ip,jp
  integer(i_kind),intent(in   ) :: nx0,ny0
  real(r_kind)   ,intent(in   ) :: x,y
  real(r_kind)   ,intent(in   ) :: x0(nx0,ny0),y0(nx0,ny0)

  real(r_kind) dista,distb,dist2,dist2min
  integer(i_kind) i,inext,j,jnext

  do
     i0=ilast
     j0=jlast
     dist2min=huge(dist2min)
     inext=0
     jnext=0
     do j=max(j0-1,1),min(j0+1,ny0)
        do i=max(i0-1,1),min(i0+1,nx0)
           dist2=(x-x0(i,j))**2+(y-y0(i,j))**2
           if(dist2<dist2min) then
              dist2min=dist2
              inext=i
              jnext=j
           end if
        end do
     end do
     if(inext==i0.and.jnext==j0) exit
     ilast=inext
     jlast=jnext
  end do

!  now find which way to go in x for second point

  ip=0
  if(i0==nx0)  ip=-1
  if(i0==1) ip=1
  if(ip==0) then
     dista=(x-x0(i0-1,j0))**2+(y-y0(i0-1,j0))**2
     distb=(x-x0(i0+1,j0))**2+(y-y0(i0+1,j0))**2
     if(distb<dista) then
        ip=1
     else
        ip=-1
     end if
  end if

!  repeat for y for 3rd point

  jp=0
  if(j0==ny0  ) jp=-1
  if(j0==1 ) jp=1
  if(jp==0) then
     dista=(x-x0(i0,j0-1))**2+(y-y0(i0,j0-1))**2
     distb=(x-x0(i0,j0+1))**2+(y-y0(i0,j0+1))**2
     if(distb<dista) then
        jp=1
     else
        jp=-1
     end if
  end if

  ilast=i0
  jlast=j0

end subroutine general_nearest_3

subroutine general_get_xytilde_domain(gt,nx0,ny0,rlons0,rlats0, &
                                  nx,ny,xminout,xmaxout,yminout,ymaxout)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    get_xytilde_domain
!   prgmmr:
!
! abstract:
!
! program history log:
!   2009-08-04  lueken - added subprogram doc block
!
!   input argument list:
!    nx0,ny0
!    rlons0,rlats0
!
!   output argument list:
!    nx,ny
!    xminout,xmaxout,yminout,ymaxout
!
! attributes:
!   language: f90
!   machine:
!
!$$$ end documentation block

   use kinds, only: r_kind,i_kind
   use constants, only: one, deg2rad,half,zero,r10
!  define parameters for xy domain which optimally overlays input grid

  implicit none

  type(llxy_cons),intent(inout) :: gt
  integer(i_kind),intent(in   ) :: nx0,ny0
  real(r_kind)   ,intent(in   ) :: rlons0(nx0,ny0),rlats0(nx0,ny0)

  integer(i_kind),intent(  out) :: nx,ny
  real(r_kind)   ,intent(  out) :: xminout,xmaxout,yminout,ymaxout

  real(r_kind),parameter:: r37=37.0_r_kind

  real(r_kind) area,areamax,areamin,extra,rlats0max,rlats0min,testlambda
  real(r_kind) xthis,ythis
  integer(i_kind) i,ip1,j,jp1,m

  real(r_kind) coslon0(nx0,ny0),sinlon0(nx0,ny0)
  real(r_kind) coslat0(nx0,ny0),sinlat0(nx0,ny0)
  real(r_kind) count,delbar
  real(r_kind) dx,dy,disti,distj,distmin,distmax
  real(r_kind) xmin,xmax,ymin,ymax

!  get range of lats for input grid

  rlats0max=maxval(rlats0) ; rlats0min=minval(rlats0)

!   assign hemisphere ( parameter sign_pole )

  if(rlats0min>-r37*deg2rad) gt%sign_pole=-one   !  northern hemisphere xy domain
  if(rlats0max< r37*deg2rad) gt%sign_pole= one   !  southern hemisphere xy domain

!   get optimum rotation angle rlambda0

  areamin= huge(areamin)
  areamax=-huge(areamax)
  do m=0,359
     testlambda=m*deg2rad
     xmax=-huge(xmax)
     xmin= huge(xmin)
     ymax=-huge(ymax)
     ymin= huge(ymin)
     do j=1,ny0,ny0-1
        do i=1,nx0
           xthis=(gt%pihalf+gt%sign_pole*rlats0(i,j))*cos(rlons0(i,j)+testlambda)
           ythis=(gt%pihalf+gt%sign_pole*rlats0(i,j))*sin(rlons0(i,j)+testlambda)
           xmax=max(xmax,xthis)
           ymax=max(ymax,ythis)
           xmin=min(xmin,xthis)
           ymin=min(ymin,ythis)
        end do
     end do
     do j=1,ny0
        do i=1,nx0,nx0-1
           xthis=(gt%pihalf+gt%sign_pole*rlats0(i,j))*cos(rlons0(i,j)+testlambda)
           ythis=(gt%pihalf+gt%sign_pole*rlats0(i,j))*sin(rlons0(i,j)+testlambda)
           xmax=max(xmax,xthis)
           ymax=max(ymax,ythis)
           xmin=min(xmin,xthis)
           ymin=min(ymin,ythis)
        end do
     end do
     area=(xmax-xmin)*(ymax-ymin)
     areamax=max(area,areamax)
     if(area<areamin) then
        areamin =area
        gt%rlambda0=testlambda
        xmaxout =xmax
        xminout =xmin
        ymaxout =ymax
        yminout =ymin
     end if
  end do

!   now determine resolution of input grid and choose nx,ny of xy grid accordingly
!                 (currently hard-wired at 1/2 the average input grid increment)

  do j=1,ny0
     do i=1,nx0
        coslon0(i,j)=cos(one*rlons0(i,j)) ; sinlon0(i,j)=sin(one*rlons0(i,j))
        coslat0(i,j)=cos(one*rlats0(i,j)) ; sinlat0(i,j)=sin(one*rlats0(i,j))
     end do
  end do

  delbar=zero
  count =zero
  do j=1,ny0-1
     jp1=j+1
     do i=1,nx0-1
        ip1=i+1
        disti=acos(sinlat0(i,j)*sinlat0(ip1,j)+coslat0(i,j)*coslat0(ip1,j)* &
                  (sinlon0(i,j)*sinlon0(ip1,j)+coslon0(i,j)*coslon0(ip1,j)))
        distj=acos(sinlat0(i,j)*sinlat0(i,jp1)+coslat0(i,j)*coslat0(i,jp1)* &
                  (sinlon0(i,j)*sinlon0(i,jp1)+coslon0(i,j)*coslon0(i,jp1)))
        distmax=max(disti,distj)
        distmin=min(disti,distj)
        delbar=delbar+distmax
        count=count+one
     end do
  end do
  delbar=delbar/count
  dx=half*delbar
  dy=dx

!   add extra space to computational grid to push any boundary problems away from
!     area of interest

  extra=r10*dx
  xmaxout=xmaxout+extra
  xminout=xminout-extra
  ymaxout=ymaxout+extra
  yminout=yminout-extra
  nx=1+(xmaxout-xminout)/dx
  ny=1+(ymaxout-yminout)/dy

end subroutine general_get_xytilde_domain

!-------------------------------------------------------------------------
!    NOAA/NCEP, National Centers for Environmental Prediction GSI        !
!-------------------------------------------------------------------------
!BOP
!
! !IROUTINE:  general_rotate_wind_ll2xy ---  Rotate earth vector wind
!
! !INTERFACE:
!
  subroutine general_rotate_wind_ll2xy(gt,u0,v0,u,v,rlon0,x,y)

! !USES:

    use kinds, only: r_kind,i_kind
    use constants, only: one,two,one_tenth
    implicit none

! !INPUT PARAMETERS:

    type(llxy_cons),intent(in) :: gt
    real(r_kind),intent(in   ) :: u0,v0        ! earth wind component
    real(r_kind),intent(in   ) :: rlon0        ! earth   lon (radians)
    real(r_kind),intent(in   ) :: x,y          ! local x,y coordinate (grid units)

! !OUTPUT PARAMETERS:

    real(r_kind),intent(  out) :: u,v          ! rotated coordinate of winds

! !DESCRIPTION: to convert earth vector wind components to corresponding
!           local x,y coordinate
!
! !REVISION HISTORY:
!   2003-09-30  parrish
!   2004-05-13  kleist, documentation
!   2004-07-15  todling, protex-compliant prologue
!   2010-09-08  parrish, remove sign_pole variable--no longer needed, due to more accurate and
!                 robust computation of reference wind rotation angle defined by
!                 cos_beta_ref, sin_beta_ref.
!
! !REMARKS:
!   language: f90
!   machine:  ibm rs/6000 sp; SGI Origin 2000; Compaq/HP
!
! !AUTHOR:
!   parrish          org: np22                date: 2003-09-30
!
!EOP
!-------------------------------------------------------------------------

  real(r_kind) beta,delx,delxp,dely,delyp
  real(r_kind) sin_beta,cos_beta
  integer(i_kind) ix,iy

!  interpolate departure from longitude part of angle between earth positive east and local positive x

  ix=x
  iy=y
  ix=max(1,min(ix,gt%nlon-1))
  iy=max(1,min(iy,gt%nlat-1))
  delx=x-ix
  dely=y-iy
  delxp=one-delx
  delyp=one-dely
  cos_beta=gt%cos_beta_ref(ix  ,iy  )*delxp*delyp+gt%cos_beta_ref(ix+1,iy  )*delx *delyp+ &
           gt%cos_beta_ref(ix  ,iy+1)*delxp*dely +gt%cos_beta_ref(ix+1,iy+1)*delx *dely
  sin_beta=gt%sin_beta_ref(ix  ,iy  )*delxp*delyp+gt%sin_beta_ref(ix+1,iy  )*delx *delyp+ &
           gt%sin_beta_ref(ix  ,iy+1)*delxp*dely +gt%sin_beta_ref(ix+1,iy+1)*delx *dely
  beta=atan2(sin_beta,cos_beta)

!  now rotate;

  u= u0*cos(beta-rlon0)+v0*sin(beta-rlon0)
  v=-u0*sin(beta-rlon0)+v0*cos(beta-rlon0)

end subroutine general_rotate_wind_ll2xy

!-------------------------------------------------------------------------
!    NOAA/NCEP, National Centers for Environmental Prediction GSI        !
!-------------------------------------------------------------------------
!BOP
!
! !IROUTINE:  rotate_wind_xy2ll ---  Unrotate earth vector wind
!
! !INTERFACE:
!
  subroutine general_rotate_wind_xy2ll(gt,u,v,u0,v0,rlon0,x,y)

! !USES:

    use kinds, only: r_kind,i_kind
    use constants, only: one
    implicit none

! !INPUT PARAMETERS:

    type(llxy_cons),intent(in) :: gt
    real(r_kind),intent(in   ) :: u,v         ! rotated coordinate winds
    real(r_kind),intent(in   ) :: rlon0       ! earth   lon     (radians)
    real(r_kind),intent(in   ) :: x,y         ! rotated lon/lat (radians)

! !OUTPUT PARAMETERS:

    real(r_kind),intent(  out) :: u0,v0       ! earth winds

! !DESCRIPTION: rotate u,v in local x,y coordinate to u0,v0 in earth
!           lat, lon coordinate
!
! !REVISION HISTORY:
!   2003-09-30  parrish
!   2004-05-13  kleist, documentation
!   2004-07-15  todling, protex-compliant prologue
!   2004-07-20  todling, fixed description
!   2010-09-08  parrish, remove sign_pole variable--no longer needed, due to more accurate and
!                 robust computation of reference wind rotation angle defined by
!                 cos_beta_ref, sin_beta_ref.
!
! !REMARKS:
!   language: f90
!   machine:  ibm rs/6000 sp; SGI Origin 2000; Compaq/HP
!
! !AUTHOR:
!   parrish          org: np22                date: 2003-09-30
!
!EOP
!-------------------------------------------------------------------------
  real(r_kind) beta,delx,delxp,dely,delyp
  real(r_kind) sin_beta,cos_beta
  integer(i_kind) ix,iy

!  interpolate departure from longitude part of angle between earth
!  positive east and local positive x

  ix=x
  iy=y
  ix=max(1,min(ix,gt%nlon-1))
  iy=max(1,min(iy,gt%nlat-1))
  delx=x-ix
  dely=y-iy
  delxp=one-delx
  delyp=one-dely
  cos_beta=gt%cos_beta_ref(ix  ,iy  )*delxp*delyp+gt%cos_beta_ref(ix+1,iy  )*delx *delyp+ &
           gt%cos_beta_ref(ix  ,iy+1)*delxp*dely +gt%cos_beta_ref(ix+1,iy+1)*delx *dely
  sin_beta=gt%sin_beta_ref(ix  ,iy  )*delxp*delyp+gt%sin_beta_ref(ix+1,iy  )*delx *delyp+ &
           gt%sin_beta_ref(ix  ,iy+1)*delxp*dely +gt%sin_beta_ref(ix+1,iy+1)*delx *dely
  beta=atan2(sin_beta,cos_beta)

!  now rotate;

  u0= u*cos(beta-rlon0)-v*sin(beta-rlon0)
  v0= u*sin(beta-rlon0)+v*cos(beta-rlon0)

end subroutine general_rotate_wind_xy2ll

end module general_tll2xy_mod

subroutine merge_grid_e_to_grid_a_initialize(region_lat_e,region_lon_e,region_lat_a,region_lon_a, &
                                   nlat_e,nlon_e,nlat_a,nlon_a,nord_e2a,nord_blend,nmix,gt_e,gt_a,p_e2a)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    merge_grid_e_to_grid_a_initialize
!   prgmmr:  parrish
!
! abstract:  initialize parameters needed for routines merge_grid_e_to_grid_a and merge_vgrid_e_to_vgrid_a.
!
! program history log:
!   2010-10-28  parrish - initial documentation
!   2012-03-01  tong - modified the way to call create_egrid2points_slow. If nmix <= 0, the orginal
!               way to call the subroutine will cause segmentation fault
!
!   input argument list:
!    region_lat_e - earth lats for e grid (radians)
!    region_lon_e - earth lons for e grid (radians)
!    region_lat_a - earth lats for a grid (radians)
!    region_lon_a - earth lons for a grid (radians)
!    nlat_e       - "y" dimension of e grid
!    nlon_e       - "x" dimension of e grid
!    nlat_a       - "y" dimension of a grid
!    nlon_a       - "x" dimension of a grid
!    nord_e2a     - order of accuracy of interpolation from grid e to grid a (1=bilinear, 2=biquadratic, etc)
!    nord_blend   - order of continuity of blend function (1=continuous 1st derivative, etc)
!    nmix         - width of blend zone on edge of e grid in e grid units.
!
!   output argument list:
!    gt_e         - navigation structure variable for grid e
!    gt_a         - navigation structure variable for grid a
!    p_e2a        - structure variable containing interpolation info for interpolation from e grid to a grid
!
! attributes:
!   language: f90
!   machine:
!
!$$$ end documentation block

  use kinds, only: r_kind,i_kind
  use general_tll2xy_mod, only: llxy_cons,general_create_llxy_transform,general_tll2xy
  use egrid2agrid_mod, only: egrid2agrid_parm,create_egrid2points_slow
  use constants, only: zero,one
  implicit none

  type(llxy_cons),intent(inout):: gt_e,gt_a
  type(egrid2agrid_parm),intent(inout) :: p_e2a
  integer(i_kind),intent(in):: nlat_e,nlon_e,nlat_a,nlon_a,nord_e2a,nord_blend,nmix
  real(r_kind),intent(in)::region_lat_e(nlat_e,nlon_e),region_lon_e(nlat_e,nlon_e)
  real(r_kind),intent(in)::region_lat_a(nlat_a,nlon_a),region_lon_a(nlat_a,nlon_a)

  integer(i_kind) i,j,np
  real(r_kind),allocatable::xa_e(:,:),ya_e(:,:),xe(:),ye(:)
  logical outside
  real(r_kind) diffmax,range_lat,range_lon

! define navigation for e grid and a grid

  if(nlat_e == nlat_a .and. nlon_e == nlon_a) then
     range_lat=max(abs(region_lat_a(nlat_a,1)-region_lat_a(1,1)),abs(region_lat_a(nlat_a,nlon_a)-region_lat_a(1,nlon_a)))
     range_lat=max(range_lat,abs(region_lat_a(nlat_a,nlon_a/2)-region_lat_a(1,nlon_a/2)))
     range_lat=max(range_lat,abs(region_lat_e(nlat_e,1)-region_lat_e(1,1)))
     range_lat=max(range_lat,abs(region_lat_e(nlat_e,nlon_e)-region_lat_e(1,nlon_e)))
     range_lat=max(range_lat,abs(region_lat_e(nlat_e,nlon_e/2)-region_lat_e(1,nlon_e/2)))
     if(nlat_a == 1) range_lat=one
     range_lon=max(abs(region_lon_a(1,nlon_a)-region_lon_a(1,1)),abs(region_lon_a(nlat_a,nlon_a)-region_lon_a(nlat_a,1)))
     range_lon=max(range_lon,abs(region_lon_a(nlat_a/2,nlon_a)-region_lon_a(nlat_a/2,1)))
     range_lon=max(range_lon,abs(region_lon_e(1,nlon_e)-region_lon_e(1,1)))
     range_lon=max(range_lon,abs(region_lon_e(nlat_e,nlon_e)-region_lon_e(nlat_e,1)))
     range_lon=max(range_lon,abs(region_lon_e(nlat_e/2,nlon_e)-region_lon_e(nlat_e/2,1)))
     if(nlon_a == 1) range_lon=one
     diffmax=zero
     do j=1,nlon_a
        do i=1,nlat_a
           diffmax=max(diffmax,abs(region_lat_a(i,j)-region_lat_e(i,j))/range_lat)
        end do
     end do
     do j=1,nlon_a
        do i=1,nlat_a
           diffmax=max(diffmax,abs(region_lon_a(i,j)-region_lon_e(i,j))/range_lon)
        end do
     end do
     if(diffmax < .0000001_r_kind)then
        p_e2a%identity=.true.
        return
     end if
  end if

  call general_create_llxy_transform(region_lat_e,region_lon_e,nlat_e,nlon_e,gt_e)
  call general_create_llxy_transform(region_lat_a,region_lon_a,nlat_a,nlon_a,gt_a)

!    obtain xa_e, ya_e, the coordinates of the a grid points in e-grid measure.

  allocate(xa_e(nlat_a,nlon_a),ya_e(nlat_a,nlon_a))
  do j=1,nlon_a
     do i=1,nlat_a
        call general_tll2xy(gt_e,region_lon_a(i,j),region_lat_a(i,j),xa_e(i,j),ya_e(i,j),outside)
     end do
  end do

  allocate(xe(nlon_e),ye(nlat_e))
  do j=1,nlon_e
     xe(j)=j
  end do
  do i=1,nlat_e
     ye(i)=i
  end do
  np=nlat_a*nlon_a
  if(nord_blend > 0 .and. nmix > 0)then
     call create_egrid2points_slow(np,ya_e,xa_e,nlat_e,ye,nlon_e,xe,nord_e2a,p_e2a,nord_blend,nmix)
  else
     call create_egrid2points_slow(np,ya_e,xa_e,nlat_e,ye,nlon_e,xe,nord_e2a,p_e2a)
  end if

  deallocate(xe,ye,xa_e,ya_e)

end subroutine merge_grid_e_to_grid_a_initialize

subroutine merge_grid_e_to_grid_a(e_in,a_in,a_out,gt_e,gt_a,p_e2a)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    merge_grid_e_to_grid_a  merge scalar field from one grid to another
!   prgmmr: parrish          org: np22                date: 2010-11-02
!
! abstract: interpolate input scalar field e_in from e grid to a grid, blend with existing
!             field a_in, and return result in a_out.
!
! program history log:
!   2010-11-02  parrish, initial documentation
!
!   input argument list:
!      e_in:             input field on e-grid
!      a_in:             input field on a-grid
!      gt_e:             structure variable containing navigation info and dimensions for e_in
!      gt_a:             same for a_in, a_out
!      p_e2a:            structure variable containing info for interpolating from e-grid to a-grid.
!
!   output argument list:
!      a_out:            blended field with interpolated e-grid field smoothly replacing
!                           region of a-grid covered by e-grid.
!
!
! attributes:
!   language: f90
!   machine:  ibm RS/6000 SP
!
!$$$ end documentation block
  use kinds, only: r_kind,i_kind
  use general_tll2xy_mod, only: llxy_cons
  use egrid2agrid_mod, only: egrid2agrid_parm,egrid2points
  use constants, only: one
  implicit none

  type(llxy_cons),intent(in):: gt_e,gt_a
  type(egrid2agrid_parm),intent(in):: p_e2a
  real(r_kind),intent(in),dimension(gt_e%nlat,gt_e%nlon):: e_in
  real(r_kind),intent(in),dimension(gt_a%nlat,gt_a%nlon):: a_in
  real(r_kind),intent(out),dimension(gt_a%nlat,gt_a%nlon):: a_out

  integer(i_kind) i,ii,j

  call egrid2points(p_e2a,e_in,a_out)
  ii=0
  do j=1,gt_a%nlon
     do i=1,gt_a%nlat
        ii=ii+1
!   blend smoothly with a_in
        a_out(i,j)=p_e2a%blend(ii)*a_out(i,j)+(one-p_e2a%blend(ii))*a_in(i,j)
!        a_out(i,j)=blend(i,j)*a_out(i,j)+(one-blend(i,j))*a_in(i,j)
     end do
  end do

end subroutine merge_grid_e_to_grid_a

subroutine merge_vgrid_e_to_vgrid_a(eu_in,ev_in,au_in,av_in,au_out,av_out,gt_e,gt_a,p_e2a)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    merge_vgrid_e_to_vgrid_a  merge vector field from one grid to another
!   prgmmr: parrish          org: np22                date: 2010-11-02
!
! abstract: interpolate input vector field eu_in,ev_in from e grid to a grid, blend with existing
!             vector field au_in, av_in, and return result in au_out,av_out.
!
! program history log:
!   2010-11-02  parrish, initial documentation
!
!   input argument list:
!      eu_in:            input u component on e-grid
!      ev_in:            input v component on e-grid
!      au_in:            input u component on a-grid
!      av_in:            input v component on a-grid
!      gt_e:             structure variable containing navigation info and dimensions for eu_in, ev_in
!      gt_a:             same for au_in, av_in, au_out,av_out
!      p_e2a:            structure variable containing info for interpolating from e-grid to a-grid.
!
!   output argument list:
!      au_out:           blended u component with interpolated e-grid u component smoothly replacing
!                           region of a-grid covered by e-grid.
!      av_out:           same for v component
!
!
! attributes:
!   language: f90
!   machine:  ibm RS/6000 SP
!
!$$$ end documentation block
  use kinds, only: r_kind,i_kind
  use general_tll2xy_mod, only: llxy_cons,general_rotate_wind_ll2xy,general_rotate_wind_xy2ll
  use egrid2agrid_mod, only: egrid2agrid_parm,egrid2points
  use constants, only: one
  implicit none

  type(llxy_cons),intent(in):: gt_e,gt_a
  type(egrid2agrid_parm),intent(in):: p_e2a
  real(r_kind),intent(in),dimension(gt_e%nlat,gt_e%nlon):: eu_in,ev_in
  real(r_kind),intent(in),dimension(gt_a%nlat,gt_a%nlon):: au_in,av_in
  real(r_kind),intent(out),dimension(gt_a%nlat,gt_a%nlon):: au_out,av_out

  integer(i_kind) i,ii,j
  real(r_kind) xa,ya,au_earth,av_earth

  call egrid2points(p_e2a,eu_in,au_out)
  call egrid2points(p_e2a,ev_in,av_out)
  ii=0
  do j=1,gt_a%nlon
     xa=j
     do i=1,gt_a%nlat
        ya=i
        ii=ii+1
!    rotate vector from e grid orientation to earth lat-lon orientation
        call general_rotate_wind_xy2ll(gt_e,au_out(i,j),av_out(i,j),au_earth,av_earth, &
                                       gt_a%region_lon(i,j),p_e2a%xa_e(ii),p_e2a%ya_e(ii))
!    rotate vector from earth lat-lon orientation to a grid orientation
        call general_rotate_wind_ll2xy(gt_a,au_earth,av_earth,au_out(i,j),av_out(i,j), &
                                       gt_a%region_lon(i,j),xa,ya)
!   blend smoothly with au_in, av_in
        au_out(i,j)=p_e2a%blend(ii)*au_out(i,j)+(one-p_e2a%blend(ii))*au_in(i,j)
        av_out(i,j)=p_e2a%blend(ii)*av_out(i,j)+(one-p_e2a%blend(ii))*av_in(i,j)
!        au_out(i,j)=blend(i,j)*au_out(i,j)+(one-blend(i,j))*au_in(i,j)
!        av_out(i,j)=blend(i,j)*av_out(i,j)+(one-blend(i,j))*av_in(i,j)
     end do
  end do

end subroutine merge_vgrid_e_to_vgrid_a

subroutine test1_general_ll2xy

!  compare subroutines tll2xy with general_tll2xy, etc. also for txy2ll, rotate_wind_xy2ll, rotate_wind_ll2xy
!   using analysis grid defined by region_lon,region_lat, nlon, nlat from gridmod.f90

  use gridmod, only: region_lat,region_lon,nlat,nlon,tll2xy,txy2ll,rotate_wind_xy2ll,rotate_wind_ll2xy
  use general_tll2xy_mod, only: llxy_cons,general_create_llxy_transform,general_tll2xy,general_txy2ll
  use general_tll2xy_mod, only: general_rotate_wind_ll2xy,general_rotate_wind_xy2ll
  use mpimod, only: mype
  use kinds, only: r_kind,i_kind
  use constants, only: zero
  implicit none

  type(llxy_cons) gt_a
  integer(i_kind) i,j
  real(r_kind) grid_lats(nlat,nlon),grid_lons(nlat,nlon)
  real(r_kind) grid_lats_test(nlat,nlon),grid_lons_test(nlat,nlon)
  real(r_kind) rlat,rlon,y,x,rlat_test,rlon_test,errmax_lat,errmax_lon
  real(r_kind) u,v,ug,vg,utest,vtest,ugtest,vgtest,errmax_w,errmax_wg
  real(r_kind) xmax,ymax,wgmax
  logical outside

  call general_create_llxy_transform(region_lat,region_lon,nlat,nlon,gt_a)

!             first convert region_lat,region_lon to grid units for both tll2xy and general_tll2xy
  do j=1,nlon
     do i=1,nlat
        call general_tll2xy(gt_a,region_lon(i,j),region_lat(i,j), &
                            grid_lons_test(i,j),grid_lats_test(i,j),outside)
        call tll2xy(region_lon(i,j),region_lat(i,j),grid_lons(i,j),grid_lats(i,j),outside)
     end do
  end do
!              compare grid_lons_test, grid_lats_test to grid_lons,grid_lats--should be identical
  if(mype==0) then
      write(0,*)' min,max grid_lons=',minval(grid_lons),maxval(grid_lons)
      write(0,*)' min,max grid_lons_test=',minval(grid_lons_test),maxval(grid_lons_test)
      write(0,*)' min,max grid_lats=',minval(grid_lats),maxval(grid_lats)
      write(0,*)' min,max grid_lats_test=',minval(grid_lats_test),maxval(grid_lats_test)
      write(0,*)' max err grid_lons_test=',maxval(abs(grid_lons-grid_lons_test))
      write(0,*)' max err grid_lats_test=',maxval(abs(grid_lats-grid_lats_test))
  end if
  errmax_lat=zero
  errmax_lon=zero
  errmax_w=zero
  errmax_wg=zero
  xmax=zero
  ymax=zero
  wgmax=zero

!             repeat for random x,y and random ug,vg to also test rotate_wind_xy2ll, rotate_wind_ll2xy
!                  against general_rotate_wind_xy2ll, general_rotate_wind_ll2xy
  do i=1,nlon*nlat
     call random_number(x)
     call random_number(y)
     call random_number(ug)
     call random_number(vg)
     wgmax=max(sqrt(ug**2+vg**2),wgmax)
     x=-4._r_kind+(nlon+8._r_kind)*x
     y=-4._r_kind+(nlat+8._r_kind)*y
     xmax=max(xmax,x)
     ymax=max(ymax,y)
     call general_txy2ll(gt_a,x,y,rlon_test,rlat_test)
     call txy2ll(x,y,rlon,rlat)
     errmax_lat=max(abs(rlat_test-rlat),errmax_lat)
     errmax_lon=max(abs(rlon_test-rlon),errmax_lon)
     call general_rotate_wind_xy2ll(gt_a,ug,vg,utest,vtest,rlon_test,x,y)
     call rotate_wind_xy2ll(ug,vg,u,v,rlon,x,y)
     errmax_w=max(sqrt((u-utest)**2+(v-vtest)**2),errmax_w)
     call general_rotate_wind_ll2xy(gt_a,utest,vtest,ugtest,vgtest,rlon_test,x,y)
     call rotate_wind_ll2xy(u,v,ug,vg,rlon,x,y)
     errmax_wg=max(sqrt((ug-ugtest)**2+(vg-vgtest)**2),errmax_wg)
  end do
!     check differences--should be zero
  if(mype==0) then
     write(0,*)' for txy2ll, errmax_lon,lat=',errmax_lon,errmax_lat
     write(0,*)' for rotate_wind, errmax_w,wg=',errmax_w,errmax_wg
     write(0,*)' for rotate_wind, xmax,ymax,wgmax=',xmax,ymax,wgmax
  end if

end subroutine test1_general_ll2xy

subroutine test3_egrid2points

!    test new subroutine egrid2points, which interpolates from e-grid to a-grid, where e-grid can be
!      different projection than a-grid, and need not completely cover a-grid.

!  (there seems to be a problem with interpolating vector fields that is related to how they are rotated
!    after interpolation--I am looking into this).

  use gridmod, only: region_lat,region_lon,nlat,nlon,tll2xy,txy2ll,rotate_wind_xy2ll,rotate_wind_ll2xy
  use general_tll2xy_mod, only: llxy_cons,general_create_llxy_transform,general_tll2xy,general_txy2ll
  use general_tll2xy_mod, only: general_rotate_wind_ll2xy,general_rotate_wind_xy2ll
  use mpimod, only: mype
  use kinds, only: r_kind,i_kind,r_single
  use constants, only: zero,one,two,pi,rad2deg
  use egrid2agrid_mod, only: egrid2agrid_parm,create_egrid2points_slow,egrid2points
  implicit none

  type(llxy_cons) gt_e,gt_a
  type(egrid2agrid_parm) p_e2a
  integer(i_kind) i,j,nye,nxe,nord_e2a
  real(r_kind) y(1),x(1),errmax,fmax
  real(r_kind) region_lat1(1),region_lon1(1)
  real(r_kind) rotate3,xmin,xmax,ymin,ymax
  real(r_kind),allocatable,dimension(:,:)::region_lat_e,region_lon_e
  real(r_kind),allocatable,dimension(:,:)::testlona,testlata,test_stream_e,test_stream_a
  real(r_kind),allocatable,dimension(:,:)::exact_stream_a
  real(r_single),allocatable:: out1(:,:),out2(:,:)
  real(r_kind),allocatable,dimension(:,:)::ue,ve,ua,va,uearth_a,vearth_a,uearth_e,vearth_e,ua_exact,va_exact
  real(r_kind) uearth_test,vearth_test,xe,ye,xa,ya
  integer(i_kind) nmix,nord_blend
  integer(i_kind) ii

  nmix=10
  nord_blend=4

!  1.  define subgrid which is rotated with respect to analysis grid
!       the way perhaps to do this is to define a rotated polar-stereo grid
!        then get lats and lons of this grid using rpolar2ll.

                       if(mype==0) write(0,*)' at 1 in test3'
  rotate3=pi/4._r_kind
  xmin=huge(xmin)
  xmax=-huge(xmax)
  ymin=huge(ymin)
  ymax=-huge(ymax)
  do j=nlon/3,2*nlon/3
     do i=nlat/3,2*nlat/3
        region_lat1(1)=region_lat(i,j)
        region_lon1(1)=region_lon(i,j)
        call ll2rpolar(region_lat1,region_lon1,1,x,y, &
                       region_lat(nlat/2,nlon/2),region_lon(nlat/2,nlon/2),rotate3)
        xmin=min(x(1),xmin)
        xmax=max(x(1),xmax)
        ymin=min(y(1),ymin)
        ymax=max(y(1),ymax)
     end do
  end do
                       if(mype==0) write(0,*)' min,max(region_lat)=',minval(region_lat),maxval(region_lat)
  xmin=.8_r_kind*xmin
  xmax=.8_r_kind*xmax
  ymin=.8_r_kind*ymin
  ymax=.8_r_kind*ymax
                 if(mype==0) write(0,*)' xmin,max,ymin,max=',xmin,xmax,ymin,ymax
  nxe=nlon/3
  nye=nlat/3
  allocate(region_lat_e(nye,nxe),region_lon_e(nye,nxe))
  do j=1,nxe
     x(1)=xmin+(xmax-xmin)*(j-one)/(nxe-one)
     do i=1,nye
        y(1)=ymin+(ymax-ymin)*(i-one)/(nye-one)
        call rpolar2ll(x,y,1,region_lat1,region_lon1, &
                       region_lat(nlat/2,nlon/2),region_lon(nlat/2,nlon/2),rotate3)
        region_lat_e(i,j)=region_lat1(1)
        region_lon_e(i,j)=region_lon1(1)
     end do
  end do
  allocate(out1(nxe,nye))
  do i=1,nye
     do j=1,nxe
        out1(j,i)=region_lat_e(i,j)*rad2deg
     end do
  end do
  call outgrads1(out1,nxe,nye,'region_lat_e')
  do i=1,nye
     do j=1,nxe
        out1(j,i)=region_lon_e(i,j)*rad2deg
     end do
  end do
  call outgrads1(out1,nxe,nye,'region_lon_e')
                       if(mype==0) write(0,*)' min,max(region_lat_e)=',minval(region_lat_e),maxval(region_lat_e)

!  initialize merge_grid_e_to_grid_a

  nord_e2a=4
        if(mype==0) write(0,*)' at 2 in test3'
        if(mype==0) write(0,*)' min,max(region_lat_e)=',minval(region_lat_e),maxval(region_lat_e)
        if(mype==0) write(0,*)' min,max(region_lon_e)=',minval(region_lon_e),maxval(region_lon_e)
        if(mype==0) write(0,*)' min,max(region_lat)=',minval(region_lat),maxval(region_lat)
        if(mype==0) write(0,*)' min,max(region_lon)=',minval(region_lon),maxval(region_lon)
        if(mype==0) write(0,*)' nye,nxe,nlat,nlon,nord_e2a,nord_blend,nmix=',&
                                nye,nxe,nlat,nlon,nord_e2a,nord_blend,nmix
  call merge_grid_e_to_grid_a_initialize(region_lat_e,region_lon_e,region_lat,region_lon, &
                  nye,nxe,nlat,nlon,nord_e2a,nord_blend,nmix,gt_e,gt_a,p_e2a)

!  2.  interpolate earth lat field and lon field from subgrid to analysis grid.  make plots of
!             result.
  allocate(testlata(nlat,nlon),testlona(nlat,nlon),test_stream_e(nye,nxe),test_stream_a(nlat,nlon))
  allocate(exact_stream_a(nlat,nlon))
  do j=1,nxe
     do i=1,nye
        test_stream_e(i,j)=cos(region_lat_e(i,j))*sin(region_lat_e(i,j))*sin(region_lon_e(i,j))
     end do
  end do
  do j=1,nlon
     do i=1,nlat
        exact_stream_a(i,j)=cos(region_lat(i,j))*sin(region_lat(i,j))*sin(region_lon(i,j))
     end do
  end do
        if(mype==0) write(0,*)' min,max(test_stream_e)=',minval(test_stream_e),maxval(test_stream_e)
        if(mype==0) write(0,*)' min,max(exact_stream_a)=',minval(exact_stream_a),maxval(exact_stream_a)
        if(mype==0) write(0,*)' at 3 in test3'
  call merge_grid_e_to_grid_a(test_stream_e,exact_stream_a,test_stream_a,gt_e,gt_a,p_e2a)
        if(mype==0) write(0,*)' at 4 in test3'
        if(mype==0) write(0,*)' min,max(test_stream_a)=',minval(test_stream_a),maxval(test_stream_a)
  call merge_grid_e_to_grid_a(region_lat_e,region_lat,testlata,gt_e,gt_a,p_e2a)
  call merge_grid_e_to_grid_a(region_lon_e,region_lon,testlona,gt_e,gt_a,p_e2a)

  deallocate(out1)
  allocate(out1(nlon,nlat),out2(nlon,nlat))
  do i=1,nlat
     do j=1,nlon
        out1(j,i)=testlata(i,j)*rad2deg
     end do
  end do
  call outgrads1(out1,nlon,nlat,'testlata')
  do i=1,nlat
     do j=1,nlon
        out1(j,i)=testlona(i,j)*rad2deg
     end do
  end do
  call outgrads1(out1,nlon,nlat,'testlona')
  do i=1,nlat
     do j=1,nlon
        out1(j,i)=test_stream_a(i,j)
     end do
  end do
  call outgrads1(out1,nlon,nlat,'test_stream_a')
  do i=1,nlat
     do j=1,nlon
        out1(j,i)=exact_stream_a(i,j)
     end do
  end do
  call outgrads1(out1,nlon,nlat,'exact_stream_a')
  ii=0
  do j=1,nlon
     do i=1,nlat
        ii=ii+1
        out1(j,i)=p_e2a%blend(ii)
     end do
  end do
  call outgrads1(out1,nlon,nlat,'blend')
                       if(mype==0) write(0,*)' at 8 in test3'
  errmax=zero
  fmax=zero
  do j=1,nlon
     do i=1,nlat
        errmax=max(abs(testlata(i,j)-region_lat(i,j)),errmax)
        fmax=max(abs(region_lat(i,j)),fmax)
     end do
  end do
  if(mype==0) write(0,*)' for interpolated lat from e to a, errmax,fmax=',rad2deg*errmax,rad2deg*fmax
  errmax=zero
  fmax=zero
  do j=1,nlon
     do i=1,nlat
        errmax=max(abs(testlona(i,j)-region_lon(i,j)),errmax)
        fmax=max(abs(region_lon(i,j)),fmax)
     end do
  end do
  if(mype==0) write(0,*)' for interpolated lon from e to a, errmax,fmax=',rad2deg*errmax,rad2deg*fmax
!<><><><><><

!  3.  test with wind from large scale analytic stream function.
!
!       psi = cos(lat)*sin(lat)*sin(lon)
!
!       u = -dpsi/dlat = -sin(lon)*cos(2*lat)
!
!       v = (dpsi/dlon)/(1/cos(lat)) = sin(lat)*cos(lon)
!
  allocate(ue(nye,nxe),ve(nye,nxe))
  allocate(uearth_e(nye,nxe),vearth_e(nye,nxe))
  allocate(ua(nlat,nlon),va(nlat,nlon))
  allocate(ua_exact(nlat,nlon),va_exact(nlat,nlon))
  allocate(uearth_a(nlat,nlon),vearth_a(nlat,nlon))
                       if(mype==0) write(0,*)' at 9 in test3'
  do j=1,nxe
     xe=j
     do i=1,nye
        ye=i
!                      if(mype==0) write(0,*)' at 9.1 in test3,i,j,nye,nxe=',i,j,nye,nxe
        vearth_test=sin(region_lat_e(i,j))*cos(region_lon_e(i,j))
!               if(mype==0) write(0,*)' at 9.2 in test3,i,j,nye,nxe,vearth_test=',i,j,nye,nxe,vearth_test
        uearth_test=-sin(region_lon_e(i,j))*cos(two*region_lat_e(i,j))
!               if(mype==0) write(0,*)' at 9.3 in test3,i,j,nye,nxe,vearth_test=',i,j,nye,nxe,uearth_test
!           reorient from earth coordinates to e-grid coordinates
        call general_rotate_wind_ll2xy(gt_e,uearth_test,vearth_test,ue(i,j),ve(i,j), &
                                       region_lon_e(i,j),xe,ye)
!               if(mype==0) write(0,*)' at 9.4 in test3,i,j,nye,nxe,ue,ve,region_lon_e,xe,ye=',&
!                                         i,j,nye,nxe,ue(i,j),ve(i,j),region_lon_e(i,j)*rad2deg,xe,ye
     end do
  end do
                       if(mype==0) write(0,*)' at 10 in test3'
   do j=1,nlon
      xa=j
      do i=1,nlat
         ya=i
         vearth_test=sin(region_lat(i,j))*cos(region_lon(i,j))
         uearth_test=-sin(region_lon(i,j))*cos(two*region_lat(i,j))
!           reorient from earth coordinates to a-grid coordinates
         call general_rotate_wind_ll2xy(gt_a,uearth_test,vearth_test,ua_exact(i,j),va_exact(i,j), &
                                        region_lon(i,j),xa,ya)
      end do
   end do
                       if(mype==0) write(0,*)' at 11 in test3'
  call merge_vgrid_e_to_vgrid_a(ue,ve,ua_exact,va_exact,ua,va,gt_e,gt_a,p_e2a)
                       if(mype==0) write(0,*)' at 12 in test3'
   do i=1,nlat
      do j=1,nlon
         out1(j,i)=ua(i,j)
      end do
   end do
                       if(mype==0) write(0,*)' at 13 in test3'
   do i=1,nlat
      do j=1,nlon
         out2(j,i)=va(i,j)
      end do
   end do
                       if(mype==0) write(0,*)' at 14 in test3'
   call outgrads1(out1,nlon,nlat,'u1')
   call outgrads1(out2,nlon,nlat,'v1')
                       if(mype==0) write(0,*)' at 15 in test3'
   do i=1,nlat
      do j=1,nlon
         out1(j,i)=ua_exact(i,j)
      end do
   end do
   do i=1,nlat
      do j=1,nlon
         out2(j,i)=va_exact(i,j)
      end do
   end do
                       if(mype==0) write(0,*)' at 16 in test3'
   call outgrads1(out1,nlon,nlat,'u1exact')
   call outgrads1(out2,nlon,nlat,'v1exact')
                       if(mype==0) write(0,*)' at 17 in test3'
   ii=0
   do j=1,nlon
      do i=1,nlat
         ii=ii+1
         out1(j,i)=p_e2a%xa_e(ii)
      end do
   end do
   ii=0
   do j=1,nlon
      do i=1,nlat
         ii=ii+1
         out2(j,i)=p_e2a%ya_e(ii)
      end do
   end do
                       if(mype==0) write(0,*)' at 18 in test3'
   call outgrads1(out1,nlon,nlat,'xa_e')
   call outgrads1(out2,nlon,nlat,'ya_e')
                       if(mype==0) write(0,*)' at 19 in test3'

  deallocate(region_lat_e,region_lon_e)
  deallocate(out1,out2)
  deallocate(testlata,testlona,test_stream_e,test_stream_a,exact_stream_a)
  deallocate(ue,ve)
  deallocate(uearth_e,vearth_e,ua,va,ua_exact,va_exact,uearth_a,vearth_a)

end subroutine test3_egrid2points


      double precision function del2(p1,p2,p3,p4)
      implicit none
      double precision ovdot,p1(4),p2(4),p3(4),p4(4)
      del2=ovdot(p1,p3)*ovdot(p2,p4)-ovdot(p1,p4)*ovdot(p2,p3)
      return
      end