      SUBROUTINE ANGLAP(SEGSIN,NSEGSIN,SEGSOUT,MAXSEGSOUT,NSEGSOUT,
     *      LUERR,IERR)
      IMPLICIT REAL*8 (A-H,O-Z)
C
C  THIS ROUTINE FINDS THE SECTORS OF A CIRCLE THAT ARE COMMON TO
C  ALL SECTORS INPUT TO IT.
C
C
C VARIABLE  DIM     TYPE  I/O  DESCRIPTION
C --------  ---     ----  ---  -----------
C
C SEGSIN  2,NSEGSIN  R*8   I   THE SECTORS OF A CIRCLE FOR WHICH
C                              REGIONS COMMON TO ALL ARE WANTED.
C
C                              SEGSIN(1,I)=START ANGLE OF THE I'TH
C                              SECTOR.
C
C                              SEGSIN(2,I)=END ANGLE OF THE I'TH
C                              SECTOR.
C
C                              SECTOR(2,I) < SECTOR(1,I) INDICATES
C                              THAT THE SECTOR CROSSES TWOPI.
C
C                              SECTOR(1,I)=SECTOR(2,I) MEANS THE
C                              SECTOR HAS ZERO WIDTH.
C
C                              THE VALID RANGE IS ZERO TO TWOPI,
C                              INCLUDING ZERO AND TWOPI.  IN RADIANS.
C
C NSEGSIN    1      I*4    I   NUMBER OF SECTORS INPUT.  MAY BE ZERO, IN
C                              WHICH CASE NO COMMON SEGMENTS EXIST AND
C                              NSEGSOUT=0 IS RETURNED.
C
C                              MAX=361, BUT CAN BE CHANGED BY REDEFINING
C                              THE MAXIN PARAMETER BELOW AND RECOMPILING
C                              THIS ROUTINE.
C
C SEGSOUT           R*8    O   SECTORS FOUND COMMON TO ALL INPUT SECTORS
C      2,MAXSEGSOUT
C                              SEGSOUT(1,I) IS START ANGLE OF THE
C                              I'TH COMMON SECTOR. SEGSOUT(2,I) IS THE
C                              END ANGLE.  IN RADIANS.
C
C                              SECTORS ARE OUTPUT IN ASCENDING ORDER.
C                              THAT IS SEGSOUT(1,1)<SEGSOUT(2,1)<
C                              SEGSOUT(1,2)<.....<SEGSOUT(2,NSEGSOUT).
C
C                              ALL SEGSOUT VALUES ARE IN THE ZERO TO
C                              TWOPI RANGE, EXCEPT WHEN A COMMON SEGMENT
C                              CROSSES TWOPI(IN WHICH CASE SEGSOUT(1,1)
C                              IS NEGATIVE.
C
C                              SECTORS MAY HAVE ZERO WIDTH. FOR
C                              EXAMPLE, THIS ROUTINE WILL SAY THAT
C                              THE INPUT SECTORS [10 DEG, 20 DEG] AND
C                              [20 DEG, 15 DEG] HAVE TWO COMMON SECTORS,
C                              ONE BEING [10 DEG, 15 DEG] AND THE OTHER
C                              [20 DEG, 20 DEG].
C
C                              THE CALLING PROGRAM CAN USE THE SAME
C                              ARRAY FOR SEGSIN AND SEGSOUT IF DESIRED.
C                              CALL ANGLAP(SEGS,N1,SEGS,N2,N3,K1,K2) IS
C                              VALID.
C
C MAXSEGSOUT 1      I*4    I   MAX NUMBER OF PAIRS THE SEGSOUT ARRAY
C                              CAN HOLD.  IF NSEGSOUT EXCEEDS THIS,
C                              ERROR CONDITION 3 EXISTS.
C
C NSEGSOUT   1      I*4    O   NUMBER OF SEGMENTS FOUND TO BE IN COMMON
C                              WITH ALL INPUT SEGMENTS.  POSSIBLE
C                              VALUES ARE -1,0,1,2,...,NSEGSIN.  THE
C                              NEGATIVE VALUE IS RETURNED ONLY WHEN
C                              AN ERROR OCCURS(IE, IERR NON-ZERO).
C
C LUERR      1      I*4    O   FORTRAN UNIT NUMBER FOR ERROR MESSAGES.
C                              = 0 OR NEGATIVE MEANS NO MESSAGE POSSIBLE
C
C IERR       1      I*4    O   ERROR RETURN FLAG.
C                              = 0 MEANS NO ERROR FOUND.
C                              = 1 MEANS NSEGSIN IS TOO LARGE.
C                              = 2 MEANS ZERO TO TWOPI REQUIREMENT
C                                  ON SEGSIN VALUES HAS BEEN VIOLATED.
C                              = 3 MEANS MAXSEGSOUT IS TOO SMALL
C
C***********************************************************************
C
C  C PETRUZZO. 8/82.
C
C  MODIFIED.....
C        12/82. CJP. BUG CORRECTION ASSOCIATED WITH 0, TWOPI ENDPOINTS.
C         9/86. CJP. BUG CORRECTION AND COMMENT MODS TO CLARIFY THE
C                    DESCRIPTION OF THE LOGIC.  MINOR CODE CLEANUP.
C                    PREVIOUS VERSION SAID, ERRONEOUSLY, THAT SEGSOUT
C                    DIMENSION WAS (2,3).  SOME CODE MODS DONE TO
C                    CORRECT THE LOGIC IMPLICATIONS OF THAT ERROR.
C         3/87. CJP. ADDED MAXSEGSOUT ARGUMENT. LARGE INPUT ARRAYS
C                    CAN BE INPUT.  THE MOD ALLOWS SMALL OUTPUT ARRAYS
C                    TO BE USED AND AN ERROR CHECK TO SEE THAT THEY
C                    ARE NOT TOO SMALL.  INCREASED MAXIN VALUE TO
C                    ACCOMMODATE QUIKVIS PROGRAM NEEDS.
C
C***********************************************************************
C
      REAL*8 SEGSIN(2,1),SEGSOUT(2,1)
C
      PARAMETER MAXIN=361,MAXIN1=MAXIN+1
      INTEGER*2 IORD(2*MAXIN)
      REAL*8 SEGIN(2,MAXIN),SEGOUT(2,MAXIN1)
      LOGICAL*1 XTWOPI(MAXIN),LTEST,OKSOFAR,ENDPT,OKTHIS
      REAL*8 TWOPI/ 6.283185307179586D0 /
      REAL*8 DEGRAD/ 57.29577951308232D0 /
      INTEGER NERR/0/
      REAL*8 TOLER/1.D-10/
C
      IERR = 0
      IBUG = 0
      LUBUG = 19
C
      IF(IBUG.NE.0) WRITE(LUBUG,1001) NSEGSIN,
     *    ((SEGSIN(I,J)*DEGRAD,I=1,2),J=1,NSEGSIN)
 1001 FORMAT(/,' ANGLAP. NUMBER OF SEGMENTS INPUT=',I4,' SEGS='/,
     *    99(3(1X,F7.3,1X,F7.3,4X)/))
C
C
C INITIALIZATION
C
      NSEGOUT = 0
C
C    IF NO SEGS WERE INPUT, NONE ARE OUTPUT.
C
      IF(NSEGSIN.LE.0) GO TO 999
C
C ERROR CHECKS
C
C    NUMBER OF SEGS INPUT.
C
      IF(NSEGSIN.GT.MAXIN)  THEN      ! EXCEEDS SUBROUTINE CAPACITY
        IERR = 1
        IF(LUERR.GT.0) CALL MESAGE(1,NERR,50,0,1,0,LUERR,
     *        'ANGLAP. TOO MANY ANGLE SEGMENTS. NO PROCESSING DONE.')
        GO TO 999
        END IF
C
C    RANGE OF VALUES.  [0,TWOPI] ONLY VALID RANGE.  MODULO ARITHMETIC
C    IS NOT DONE HERE BECAUSE THE CALLING PROGRAM SHOULD RESOLVE THE
C    AMBIGUITY TO ENSURE THE PROPER INTERPRETATION OF WHAT START AND
C    END ANGLES MEAN.
C
      DO I=1,NSEGSIN
      DO J=1,2
        TEMP = SEGSIN(J,I)
        IF( TEMP.LT.0.D0 .OR. TEMP.GT.TWOPI+TOLER) THEN
          IERR = 2
          IF(LUERR.GT.0) CALL MESAGE(1,NERR,50,0,1,0,LUERR,
     *      'ANGLAP. INPUT ANGLES OUTSIDE [0,2PI]. NO PROCESSING DONE.')
          GO TO 999
          END IF
        END DO
        END DO
C
C
C  MORE INITIALIZATION
C
C    TRANSFER SEGSIN ARRAY TO INTERNAL ARRAY SEGIN.  MODIFY CONTENTS IF
C    THEY ARE CLOSE TO ZERO OR TWOPI TO MAKE THEM EXACTLY ZERO AND TWOPI
C
      DO J=1,NSEGSIN
        TEMP1 = SEGSIN(1,J)
        TEMP2 = SEGSIN(2,J)
        IF(TEMP1.LE.TOLER) THEN
          TEMP1 = 0.D0
          IF(TEMP2.LE.TOLER) TEMP2 = 0.D0
          IF(TEMP2.GE.TWOPI-TOLER) TEMP2 = TWOPI
        ELSE  IF(TEMP1.GE.TWOPI-TOLER) THEN
          TEMP1 = 0.D0
          IF(TEMP2.LE.TOLER .OR. TEMP2.GE.TWOPI-TOLER) TEMP2 = 0.D0
          END IF
        IF(TEMP2.LE.TOLER) THEN
          TEMP2 = 0.D0
          IF(TEMP1.GE.TOLER)  TEMP2 = TWOPI
          END IF
        SEGIN(1,J) = TEMP1
        SEGIN(2,J) = TEMP2
        END DO
      NSEGIN = NSEGSIN
C
C    DETERMINE WHETHER THE SEGMENTS CROSS TWOPI.
C
      DO I=1,NSEGIN
        XTWOPI(I) = SEGIN(2,I) .LT. SEGIN(1,I)
        END DO
      IF(IBUG.NE.0) WRITE(LUBUG,1003) (I,XTWOPI(I),I=1,NSEGIN)
 1003 FORMAT(/,' TWOPI CROSSING FLAG:'/,99(10(2X,I3,'-',L2)/))
C
C
C
C******* NOW TEST EACH END POINT TO SEE IF IT IS INCLUDED IN ALL OF THE
C        INPUT SEGMENTS.  IF SO, THEN IT IS THE START OR END POINT OF A
C        COMMOM SEGNEMT.  IF NOT, THEN IT IS IGNORED AS A POSSIBLE
C        START/END POINT.
C
C     FIRST, SEE IF THERE ARE ANY ZERO-WIDTH SEGMENTS. IF SO,
C     THIS IS A SPECIAL CASE AND IS HANDLED SEPARATELY. A ZERO-WIDTH
C     SEGMENT, IF COMMON TO ALL OTHER SEGMENTS, IS THE ONLY ONE
C     POSSIBLE FOR OUTPUT.
C
      ZANGLE = -999.D0
      I = 0
      DO WHILE (ZANGLE.LT.0.D0 .AND. I.LT.NSEGIN)
        I = I+1
        IF( SEGIN(1,I).EQ.SEGIN(2,I) ) ZANGLE = SEGIN(1,I)
        END DO
      IF(ZANGLE.GE.0.D0) THEN    ! A ZERO-WIDTH ONE WAS INPUT.
        DO I=1,NSEGIN
          SEG1 = DMIN1(SEGIN(1,I),SEGIN(2,I))
          SEG2 = DMAX1(SEGIN(1,I),SEGIN(2,I))
          ENDPT = ZANGLE.EQ.SEG1 .OR. ZANGLE.EQ.SEG2   ! AN ENDPOINT?
          LTEST = SEG1.LT.ZANGLE .AND. ZANGLE.LT.SEG2  ! AN INTERIOR PT?
          IF(XTWOPI(I)) LTEST = .NOT.LTEST
          LTEST = LTEST .OR. ENDPT   ! INTERIOR OR ENDPOINT? MUST BE YES.
          IF(.NOT.LTEST) GO TO 999    ! NOT IN ONE OF THE SEGMENTS.
          END DO
C       TO GET HERE, ANGLE VALUE HAD TO BE IN ALL SEGMENTS.
        NSEGOUT = 1
        SEGOUT(1,1) = ZANGLE
        SEGOUT(2,1) = ZANGLE
        GO TO 999
        END IF
C
C  DETERMINE THE ASCENDING ORDER OF THE SET OF ENDPOINTS.
C
      CALL ORDER8(SEGIN,2*NSEGIN,IORD)
      IF(IBUG.NE.0) WRITE(LUBUG,1002)
     *      (SEGIN(IORD(I),1)*DEGRAD,I=1,2*NSEGIN)
 1002 FORMAT(/,' ENDPOINTS IN ASCENDING ORDER:'/,
     *    1X,F7.3,9(1X,F7.3)/)
C
C  NOW CHECK EACH OF THE END POINTS TO SEE WHETHER IT IS INCLUDED IN
C  EVERY INPUT SEGMENT.  IF SO, SET NSEGOUT AND SEGOUT APPROPRIATELY.
C
      NFOUND = 0
      NSEGOUT = 0
      OLDANG = -1.D10
      NANGS = 2*NSEGIN+2   ! WANT TO TEST 0 AND TWOPI ALSO.
      DO 100 IANG=1,NANGS
C
C     FIRST, DETERMINE THE CURRENT END POINT TO BE TESTED AND SET ISUB
C     TO INDICATE WHETHER IT IS THE START(ISUB=1) OR END(ISUB(2) POINT
C     OF AN INPUT SEGMENT.
      IF(IANG.EQ.1 .OR. IANG.EQ.NANGS) THEN
        IF(IANG.EQ.1) THEN
          ANGLE = 0.D0
          ISUB = 1
        ELSE
          ANGLE = TWOPI
          ISUB = 2
          END IF
      ELSE
        INDX = IORD(IANG-1)
        ISUB = 1
        IF(MOD(INDX,2).EQ.0) ISUB = 2
        ISEG = (INDX+1)/2
        ANGLE = SEGIN(ISUB,ISEG)
        END IF
      IF(IBUG.NE.0) WRITE(LUBUG,1004) IANG,ANGLE*DEGRAD
 1004 FORMAT(/,' TESTING WITH IANG=',I3,' ANGLE=',F7.3)
C
C     CHECK EACH INPUT SEGMENT TO SEE IF THE CURRENT ENDPOINT IS IN ALL
C     OF THEM.  IF SO, IT IS THE BEGINNING OR END OF A COMMON SEGMENT.
      JSEG = 0
      OKSOFAR = .TRUE.
      DO WHILE ( JSEG.LT.NSEGIN .AND. OKSOFAR )
        JSEG = JSEG + 1
        SEG1 = DMIN1(SEGIN(1,JSEG),SEGIN(2,JSEG))
        SEG2 = DMAX1(SEGIN(1,JSEG),SEGIN(2,JSEG))
        ENDPT = ANGLE.EQ.SEG1 .OR. ANGLE.EQ.SEG2  !ENDPOINT ALWAYS 'IN'
        LTEST = SEG1.LT.ANGLE .AND. ANGLE.LT.SEG2
        IF(XTWOPI(JSEG)) LTEST = .NOT.LTEST
        OKSOFAR = LTEST .OR. ENDPT
        IF(IBUG.NE.0) WRITE(LUBUG,1005) ANGLE*DEGRAD,JSEG,SEG1*DEGRAD,
     *      SEG2*DEGRAD,XTWOPI(JSEG),LTEST,ENDPT,OKSOFAR
 1005   FORMAT(/,' ANGLE=',F7.3,' TESTING AGAINST SEG # ',I3,
     *      ' SEG1,SEG2=',2F8.3/,
     *      ' XTWOPI=',L2,'  LTEST=',L2,'  ENDPT=',L2,' OKSOFAR=',L2)
        END DO
C
      OKTHIS = OKSOFAR
C
C     IF OKTHIS=.T., THEN THIS START/END OF AN INPUT SEGMENT IS AN END
C     OR INTERIOR POINT OF ALL OTHER INPUT SEGMENTS.  THEREFORE, IT IS
C     THE START OR END OF A COMMON SEGMENT.
C
      IF(OKTHIS) THEN
C      NFOUND IS THE NUMBER OF UNIQUE ANGLE VALUES COMMON TO ALL INPUT
C      SEGMENTS.
        IF(ANGLE.NE.OLDANG) NFOUND = NFOUND+1
        NSEGOUT = (NFOUND+1)/2
        SEGOUT(ISUB,NSEGOUT) = ANGLE
        IF(IBUG.NE.0) WRITE(LUBUG,1006) ISUB,NSEGOUT,NFOUND
 1006   FORMAT(/,' FOUND ONE. ISUB=',I2,'  NSEGOUT=',I2,' NFOUND=',I2)
        END IF
C
      OLDANG = ANGLE
      IF(DABS(OLDANG-TWOPI).LE.TOLER) OLDANG = TWOPI
  100 CONTINUE
C
C ALL COMMON SEGMENTS HAVE BEEN IDENTIFIED.  IT IS POSSIBLE THAT A
C COMMON SEGMENT CROSSES TWOPI.  IF SO, THEN THE SEGOUT ARRAY REPRESENTS
C IT AS TWO SEGMENTS.  FOR EXAMPLE(IN DEGREES), IF THE COMMON SEGMENT IS
C 300 TO 30(THRU 360), THEN SEGOUT(*,1) = 0,30 AND SEGOUT(*,NSEGOUT) =
C 300,360.  WE WANT TO CHANGE THIS REPRESENTATION TO A SINGLE SEGMENT
C BY REPLACING THE TWO WITH SEGOUT(*,1) = -60,30.
C
      IF(NSEGOUT.GT.1) THEN
        IF( SEGOUT(1,1).EQ.0.D0 .AND. SEGOUT(2,NSEGOUT).EQ.TWOPI) THEN
          SEGOUT(1,1) = SEGOUT(1,NSEGOUT) - TWOPI
          NSEGOUT = NSEGOUT-1
          END IF
        END IF
C
      IF(NSEGOUT.GT.MAXSEGSOUT) THEN  ! NOT ENEOUGH SPACE IN SEGSOUT
        IERR = 3
        IF(LUERR.GT.0) CALL MESAGE(1,NERR,50,0,1,0,LUERR,
     *      'ANGLAP. MORE ANGLE SEGMENTS NEEDED THAN ARRAY HAS SLOTS.')
        GO TO 999
        END IF

C
C
  999 CONTINUE
C
C WRAP UP.
C
      IF(IERR.EQ.0) THEN
        NSEGSOUT = NSEGOUT
        IF(NSEGSOUT.GT.0) THEN
          DO I=1,NSEGSOUT
            SEGSOUT(1,I) = SEGOUT(1,I)
            SEGSOUT(2,I) = SEGOUT(2,I)
            END DO
          END IF
      ELSE
        NSEGSOUT = -1
        END IF
C
C
      IF(IBUG.NE.0) WRITE(LUBUG,1007) IERR,NSEGSOUT,
     *        ((SEGSOUT(I,J)*DEGRAD,I=1,2),J=1,NSEGOUT)
 1007 FORMAT(/,' FINISHED ANGLAP. IERR=',I2,'  NSEGSOUT=',I2/,
     *    ' SEGSOUT=',(T12,2X,2F8.3,2X,2F8.3,2X,2F8.3))
      RETURN
      END


c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1999  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  routines below implement a 1-D Fast Fourier Transform;  ##
c     ##  code is modified from FFTPACK as obtained from Netlib;  ##
c     ##  original due to Paul N. Swarztrauber, NCAR, Boulder CO  ##
c     ##                                                          ##
c     ##############################################################
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine cffti  --  1-D FFT setup and initialization  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "cffti" initializes arrays used in both forward and backward
c     transforms; "ifac" is the prime factorization of "n", and
c     "wsave" contains a tabulation of trigonometric functions
c
c
      subroutine cffti (n,wsave,ifac)
      implicit none
      integer n,iw
      integer ifac(*)
      real*8 wsave(*)
c
c
      if (n .gt. 1) then
         iw = n + n + 1
         call cffti1 (n,wsave(iw),ifac)
      end if
      return
      end
c
c
c     #########################
c     ##                     ##
c     ##  subroutine cffti1  ##
c     ##                     ##
c     #########################
c
c
      subroutine cffti1 (n,wa,ifac)
      implicit none
      include 'math.i'
      integer i,j,ii,n,ip,ipm
      integer ib,ido,idot
      integer i1,k1,l1,l2,ld
      integer nl,nf,nq,nr
      integer ntry,ntryh(4)
      integer ifac(*)
      real*8 arg,argh,argld,fi
      real*8 wa(*)
      data ntryh  / 3, 4, 2, 5 /
c
c
      nl = n
      nf = 0
      j = 1
      ntry = ntryh(j)
      do while (nl .ne. 1)
         nq = nl / ntry
         nr = nl - ntry*nq
         if (nr .eq. 0) then
            nf = nf + 1
            ifac(nf+2) = ntry
            nl = nq
            if (ntry .eq. 2) then
               if (nf .ne. 1) then
                  do i = 2, nf
                     ib = nf - i + 2
                     ifac(ib+2) = ifac(ib+1)
                  end do
                  ifac(3) = 2
               end if
            end if
         else
            j = j + 1
            if (j .le. 4) then
               ntry = ntryh(j)
            else
               ntry = ntry + 2
            end if
         end if
      end do
      ifac(1) = n
      ifac(2) = nf
      argh = 2.0d0 * pi / dble(n)
      i = 2
      l1 = 1
      do k1 = 1, nf
         ip = ifac(k1+2)
         ld = 0
         l2 = l1 * ip
         ido = n / l2
         idot = ido + ido + 2
         ipm = ip - 1
         do j = 1, ipm
            i1 = i
            wa(i-1) = 1.0d0
            wa(i) = 0.0d0
            ld = ld + l1
            fi = 0.0d0
            argld = dble(ld) * argh
            do ii = 4, idot, 2
               i = i + 2
               fi = fi + 1.0d0
               arg = fi * argld
               wa(i-1) = cos(arg)
               wa(i) = sin(arg)
            end do
            if (ip .gt. 5) then
               wa(i1-1) = wa(i-1)
               wa(i1) = wa(i)
            end if
         end do
         l1 = l2
      end do
      return
      end
c
c
c     #######################################################
c     ##                                                   ##
c     ##  subroutine cfftf  --  1-D FFT forward transform  ##
c     ##                                                   ##
c     #######################################################
c
c
c     "cfftf" computes the forward complex discrete Fourier
c     transform, the Fourier analysis
c
c
      subroutine cfftf (n,c,wsave,ifac)
      implicit none
      integer n,iw
      integer ifac(*)
      real*8 c(*)
      real*8 wsave(*)
c
c
      if (n .gt. 1) then
         iw = n + n + 1
         call cfftf1 (n,c,wsave,wsave(iw),ifac)
      end if
      return
      end
c
c
c     #########################
c     ##                     ##
c     ##  subroutine cfftf1  ##
c     ##                     ##
c     #########################
c
c
      subroutine cfftf1 (n,c,ch,wa,ifac)
      implicit none
      integer i,n,k1,l1,l2
      integer na,nac,nf,n2
      integer ido,idot,idl1,ip
      integer iw,ix2,ix3,ix4
      integer ifac(*)
      real*8 c(*),ch(*),wa(*)
c
c
      nf = ifac(2)
      na = 0
      l1 = 1
      iw = 1
      do k1 = 1, nf
         ip = ifac(k1+2)
         l2 = ip * l1
         ido = n / l2
         idot = ido + ido
         idl1 = idot * l1
         if (ip .eq. 5) then
            ix2 = iw + idot
            ix3 = ix2 + idot
            ix4 = ix3 + idot
            if (na .eq. 0) then
               call passf5 (idot,l1,c,ch,wa(iw),wa(ix2),wa(ix3),wa(ix4))
            else
               call passf5 (idot,l1,ch,c,wa(iw),wa(ix2),wa(ix3),wa(ix4))
            end if
            na = 1 - na
         else if (ip .eq. 4) then
            ix2 = iw + idot
            ix3 = ix2 + idot
            if (na .eq. 0) then
               call passf4 (idot,l1,c,ch,wa(iw),wa(ix2),wa(ix3))
            else
               call passf4 (idot,l1,ch,c,wa(iw),wa(ix2),wa(ix3))
            end if
            na = 1 - na
         else if (ip .eq. 3) then
            ix2 = iw + idot
            if (na .eq. 0) then
               call passf3 (idot,l1,c,ch,wa(iw),wa(ix2))
            else
               call passf3 (idot,l1,ch,c,wa(iw),wa(ix2))
            end if
            na = 1 - na
         else if (ip .eq. 2) then
            if (na .eq. 0) then
               call passf2 (idot,l1,c,ch,wa(iw))
            else
               call passf2 (idot,l1,ch,c,wa(iw))
            end if
            na = 1 - na
         else
            if (na .eq. 0) then
               call passf (nac,idot,ip,l1,idl1,c,c,c,ch,ch,wa(iw))
            else
               call passf (nac,idot,ip,l1,idl1,ch,ch,ch,c,c,wa(iw))
            end if
            if (nac .ne. 0)  na = 1 - na
         end if
         l1 = l2
         iw = iw + (ip-1)*idot
      end do
      if (na .ne. 0) then
         n2 = n + n
         do i = 1, n2
            c(i) = ch(i)
         end do
      end if
      return
      end
c
c
c     ########################################################
c     ##                                                    ##
c     ##  subroutine cfftb  --  1-D FFT backward transform  ##
c     ##                                                    ##
c     ########################################################
c
c
c     "cfftb" computes the backward complex discrete Fourier
c     transform, the Fourier synthesis
c
c
      subroutine cfftb (n,c,wsave,ifac)
      implicit none
      integer n,iw
      integer ifac(*)
      real*8 c(*)
      real*8 wsave(*)
c
c
      if (n .gt. 1) then
         iw = n + n + 1
         call cfftb1 (n,c,wsave,wsave(iw),ifac)
      end if
      return
      end
c
c
c     #########################
c     ##                     ##
c     ##  subroutine cfftb1  ##
c     ##                     ##
c     #########################
c
c
      subroutine cfftb1 (n,c,ch,wa,ifac)
      implicit none
      integer i,n,k1,l1,l2
      integer na,nac,nf,n2
      integer ido,idot,idl1,ip
      integer iw,ix2,ix3,ix4
      integer ifac(*)
      real*8 c(*),ch(*),wa(*)
c
c
      nf = ifac(2)
      na = 0
      l1 = 1
      iw = 1
      do k1 = 1, nf
         ip = ifac(k1+2)
         l2 = ip * l1
         ido = n / l2
         idot = ido + ido
         idl1 = idot * l1
         if (ip .eq. 5) then
            ix2 = iw + idot
            ix3 = ix2 + idot
            ix4 = ix3 + idot
            if (na .eq. 0) then
               call passb5 (idot,l1,c,ch,wa(iw),wa(ix2),wa(ix3),wa(ix4))
            else
               call passb5 (idot,l1,ch,c,wa(iw),wa(ix2),wa(ix3),wa(ix4))
            end if
            na = 1 - na
         else if (ip .eq. 4) then
            ix2 = iw + idot
            ix3 = ix2 + idot
            if (na .eq. 0) then
               call passb4 (idot,l1,c,ch,wa(iw),wa(ix2),wa(ix3))
            else
               call passb4 (idot,l1,ch,c,wa(iw),wa(ix2),wa(ix3))
            end if
            na = 1 - na
         else if (ip .eq. 3) then
            ix2 = iw + idot
            if (na .eq. 0) then
               call passb3 (idot,l1,c,ch,wa(iw),wa(ix2))
            else
               call passb3 (idot,l1,ch,c,wa(iw),wa(ix2))
            end if
            na = 1 - na
         else if (ip .eq. 2) then
            if (na .eq. 0) then
               call passb2 (idot,l1,c,ch,wa(iw))
            else
               call passb2 (idot,l1,ch,c,wa(iw))
            end if
            na = 1 - na
         else
            if (na .eq. 0) then
               call passb (nac,idot,ip,l1,idl1,c,c,c,ch,ch,wa(iw))
            else
               call passb (nac,idot,ip,l1,idl1,ch,ch,ch,c,c,wa(iw))
            end if
            if (nac .ne. 0)  na = 1 - na
         end if
         l1 = l2
         iw = iw + (ip-1)*idot
      end do
      if (na .ne. 0) then
         n2 = n + n
         do i = 1, n2
            c(i) = ch(i)
         end do
      end if
      return
      end
c
c
c     ########################
c     ##                    ##
c     ##  subroutine passf  ##
c     ##                    ##
c     ########################
c
c
      subroutine passf (nac,ido,ip,l1,idl1,cc,c1,c2,ch,ch2,wa)
      implicit none
      integer nac,ido,ip
      integer l1,idl1
      integer i,j,k,l
      integer ik,jc,lc
      integer idj,idl,idp
      integer idij,idlj
      integer inc,idot,nt
      integer ipp2,ipph
      real*8 wai,war
      real*8 cc(ido,ip,l1)
      real*8 c1(ido,l1,ip)
      real*8 c2(idl1,ip)
      real*8 ch(ido,l1,ip)
      real*8 ch2(idl1,ip)
      real*8 wa(*)
c
c
      idot = ido / 2
      nt = ip * idl1
      ipp2 = ip + 2
      ipph = (ip+1) / 2
      idp = ip * ido
      if (ido .ge. l1) then
         do j = 2, ipph
            jc = ipp2 - j
            do k = 1, l1
               do i = 1, ido
                  ch(i,k,j) = cc(i,j,k) + cc(i,jc,k)
                  ch(i,k,jc) = cc(i,j,k) - cc(i,jc,k)
               end do
            end do
         end do
         do k = 1, l1
            do i = 1, ido
               ch(i,k,1) = cc(i,1,k)
            end do
         end do
      else
         do j = 2, ipph
            jc = ipp2 - j
            do i = 1, ido
               do k = 1, l1
                  ch(i,k,j) = cc(i,j,k) + cc(i,jc,k)
                  ch(i,k,jc) = cc(i,j,k) - cc(i,jc,k)
               end do
            end do
         end do
         do i = 1, ido
            do k = 1, l1
               ch(i,k,1) = cc(i,1,k)
            end do
         end do
      end if
      idl = 2 - ido
      inc = 0
      do l = 2, ipph
         lc = ipp2 - l
         idl = idl + ido
         do ik = 1, idl1
            c2(ik,l) = ch2(ik,1) + wa(idl-1)*ch2(ik,2)
            c2(ik,lc) = -wa(idl) * ch2(ik,ip)
         end do
         idlj = idl
         inc = inc + ido
         do j = 3, ipph
            jc = ipp2 - j
            idlj = idlj + inc
            if (idlj .gt. idp)  idlj = idlj - idp
            war = wa(idlj-1)
            wai = wa(idlj)
            do ik = 1, idl1
               c2(ik,l) = c2(ik,l) + war*ch2(ik,j)
               c2(ik,lc) = c2(ik,lc) - wai*ch2(ik,jc)
            end do
         end do
      end do
      do j = 2, ipph
         do ik = 1, idl1
            ch2(ik,1) = ch2(ik,1) + ch2(ik,j)
         end do
      end do
      do j = 2, ipph
         jc = ipp2 - j
         do ik = 2, idl1, 2
            ch2(ik-1,j) = c2(ik-1,j) - c2(ik,jc)
            ch2(ik-1,jc) = c2(ik-1,j) + c2(ik,jc)
            ch2(ik,j) = c2(ik,j) + c2(ik-1,jc)
            ch2(ik,jc) = c2(ik,j) - c2(ik-1,jc)
         end do
      end do
      nac = 1
      if (ido .ne. 2) then
         nac = 0
         do ik = 1, idl1
            c2(ik,1) = ch2(ik,1)
         end do
         do j = 2, ip
            do k = 1, l1
               c1(1,k,j) = ch(1,k,j)
               c1(2,k,j) = ch(2,k,j)
            end do
         end do
         if (idot .le. l1) then
            idij = 0
            do j = 2, ip
               idij = idij + 2
               do i = 4, ido, 2
                  idij = idij + 2
                  do k = 1, l1
                     c1(i-1,k,j) = wa(idij-1)*ch(i-1,k,j)
     &                                + wa(idij)*ch(i,k,j)
                     c1(i,k,j) = wa(idij-1)*ch(i,k,j)
     &                              - wa(idij)*ch(i-1,k,j)
                  end do
               end do
            end do
         else
            idj = 2 - ido
            do j = 2, ip
               idj = idj + ido
               do k = 1, l1
                  idij = idj
                  do i = 4, ido, 2
                     idij = idij + 2
                     c1(i-1,k,j) = wa(idij-1)*ch(i-1,k,j)
     &                                + wa(idij)*ch(i,k,j)
                     c1(i,k,j) = wa(idij-1)*ch(i,k,j)
     &                              - wa(idij)*ch(i-1,k,j)
                  end do
               end do
            end do
         end if
      end if
      return
      end
c
c
c     #########################
c     ##                     ##
c     ##  subroutine passf2  ##
c     ##                     ##
c     #########################
c
c
      subroutine passf2 (ido,l1,cc,ch,wa1)
      implicit none
      integer i,k,ido,l1
      real*8 ti2,tr2
      real*8 cc(ido,2,l1)
      real*8 ch(ido,l1,2)
      real*8 wa1(*)
c
c
      if (ido .le. 2) then
         do k = 1, l1
            ch(1,k,1) = cc(1,1,k) + cc(1,2,k)
            ch(1,k,2) = cc(1,1,k) - cc(1,2,k)
            ch(2,k,1) = cc(2,1,k) + cc(2,2,k)
            ch(2,k,2) = cc(2,1,k) - cc(2,2,k)
         end do
      else
         do k = 1, l1
            do i = 2, ido, 2
               ch(i-1,k,1) = cc(i-1,1,k) + cc(i-1,2,k)
               tr2 = cc(i-1,1,k) - cc(i-1,2,k)
               ch(i,k,1) = cc(i,1,k) + cc(i,2,k)
               ti2 = cc(i,1,k) - cc(i,2,k)
               ch(i,k,2) = wa1(i-1)*ti2 - wa1(i)*tr2
               ch(i-1,k,2) = wa1(i-1)*tr2 + wa1(i)*ti2
            end do
         end do
      end if
      return
      end
c
c
c     #########################
c     ##                     ##
c     ##  subroutine passf3  ##
c     ##                     ##
c     #########################
c
c
      subroutine passf3 (ido,l1,cc,ch,wa1,wa2)
      implicit none
      integer i,k,ido,l1
      real*8 ti2,tr2,taur,taui
      real*8 ci2,ci3,cr2,cr3
      real*8 di2,di3,dr2,dr3
      real*8 cc(ido,3,l1)
      real*8 ch(ido,l1,3)
      real*8 wa1(*)
      real*8 wa2(*)
      data taur  / -0.5d0 /
      data taui  / -0.866025403784439d0 /
c
c
      if (ido .eq. 2) then
         do k = 1, l1
            tr2 = cc(1,2,k) + cc(1,3,k)
            cr2 = cc(1,1,k) + taur*tr2
            ch(1,k,1) = cc(1,1,k) + tr2
            ti2 = cc(2,2,k) + cc(2,3,k)
            ci2 = cc(2,1,k) + taur*ti2
            ch(2,k,1) = cc(2,1,k) + ti2
            cr3 = taui * (cc(1,2,k)-cc(1,3,k))
            ci3 = taui * (cc(2,2,k)-cc(2,3,k))
            ch(1,k,2) = cr2 - ci3
            ch(1,k,3) = cr2 + ci3
            ch(2,k,2) = ci2 + cr3
            ch(2,k,3) = ci2 - cr3
         end do
      else
         do k = 1, l1
            do i = 2, ido, 2
               tr2 = cc(i-1,2,k) + cc(i-1,3,k)
               cr2 = cc(i-1,1,k) + taur*tr2
               ch(i-1,k,1) = cc(i-1,1,k) + tr2
               ti2 = cc(i,2,k) + cc(i,3,k)
               ci2 = cc(i,1,k) + taur*ti2
               ch(i,k,1) = cc(i,1,k) + ti2
               cr3 = taui * (cc(i-1,2,k)-cc(i-1,3,k))
               ci3 = taui * (cc(i,2,k)-cc(i,3,k))
               dr2 = cr2 - ci3
               dr3 = cr2 + ci3
               di2 = ci2 + cr3
               di3 = ci2 - cr3
               ch(i,k,2) = wa1(i-1)*di2 - wa1(i)*dr2
               ch(i-1,k,2) = wa1(i-1)*dr2 + wa1(i)*di2
               ch(i,k,3) = wa2(i-1)*di3 - wa2(i)*dr3
               ch(i-1,k,3) = wa2(i-1)*dr3 + wa2(i)*di3
            end do
         end do
      end if
      return
      end
c
c
c     #########################
c     ##                     ##
c     ##  subroutine passf4  ##
c     ##                     ##
c     #########################
c
c
      subroutine passf4 (ido,l1,cc,ch,wa1,wa2,wa3)
      implicit none
      integer i,k,ido,l1
      real*8 ci2,ci3,ci4
      real*8 cr2,cr3,cr4
      real*8 ti1,ti2,ti3,ti4
      real*8 tr1,tr2,tr3,tr4
      real*8 cc(ido,4,l1)
      real*8 ch(ido,l1,4)
      real*8 wa1(*)
      real*8 wa2(*)
      real*8 wa3(*)
c
c
      if (ido .eq. 2) then
         do k = 1, l1
            ti1 = cc(2,1,k) - cc(2,3,k)
            ti2 = cc(2,1,k) + cc(2,3,k)
            tr4 = cc(2,2,k) - cc(2,4,k)
            ti3 = cc(2,2,k) + cc(2,4,k)
            tr1 = cc(1,1,k) - cc(1,3,k)
            tr2 = cc(1,1,k) + cc(1,3,k)
            ti4 = cc(1,4,k) - cc(1,2,k)
            tr3 = cc(1,2,k) + cc(1,4,k)
            ch(1,k,1) = tr2 + tr3
            ch(1,k,3) = tr2 - tr3
            ch(2,k,1) = ti2 + ti3
            ch(2,k,3) = ti2 - ti3
            ch(1,k,2) = tr1 + tr4
            ch(1,k,4) = tr1 - tr4
            ch(2,k,2) = ti1 + ti4
            ch(2,k,4) = ti1 - ti4
         end do
      else
         do k = 1, l1
            do i = 2, ido, 2
               ti1 = cc(i,1,k) - cc(i,3,k)
               ti2 = cc(i,1,k) + cc(i,3,k)
               ti3 = cc(i,2,k) + cc(i,4,k)
               tr4 = cc(i,2,k) - cc(i,4,k)
               tr1 = cc(i-1,1,k) - cc(i-1,3,k)
               tr2 = cc(i-1,1,k) + cc(i-1,3,k)
               ti4 = cc(i-1,4,k) - cc(i-1,2,k)
               tr3 = cc(i-1,2,k) + cc(i-1,4,k)
               ch(i-1,k,1) = tr2 + tr3
               cr3 = tr2 - tr3
               ch(i,k,1) = ti2 + ti3
               ci3 = ti2 - ti3
               cr2 = tr1 + tr4
               cr4 = tr1 - tr4
               ci2 = ti1 + ti4
               ci4 = ti1 - ti4
               ch(i-1,k,2) = wa1(i-1)*cr2 + wa1(i)*ci2
               ch(i,k,2) = wa1(i-1)*ci2 - wa1(i)*cr2
               ch(i-1,k,3) = wa2(i-1)*cr3 + wa2(i)*ci3
               ch(i,k,3) = wa2(i-1)*ci3 - wa2(i)*cr3
               ch(i-1,k,4) = wa3(i-1)*cr4 + wa3(i)*ci4
               ch(i,k,4) = wa3(i-1)*ci4 - wa3(i)*cr4
            end do
         end do
      end if
      return
      end
c
c
c     #########################
c     ##                     ##
c     ##  subroutine passf5  ##
c     ##                     ##
c     #########################
c
c
      subroutine passf5 (ido,l1,cc,ch,wa1,wa2,wa3,wa4)
      implicit none
      integer i,k,ido,l1
      real*8 ci2,ci3,ci4,ci5
      real*8 cr2,cr3,cr4,cr5
      real*8 di2,di3,di4,di5
      real*8 dr2,dr3,dr4,dr5
      real*8 ti2,ti3,ti4,ti5
      real*8 tr2,tr3,tr4,tr5
      real*8 tr11,ti11
      real*8 tr12,ti12
      real*8 cc(ido,5,l1)
      real*8 ch(ido,l1,5)
      real*8 wa1(*)
      real*8 wa2(*)
      real*8 wa3(*)
      real*8 wa4(*)
      data tr11  /  0.309016994374947d0 /
      data ti11  / -0.951056516295154d0 /
      data tr12  / -0.809016994374947d0 /
      data ti12  / -0.587785252292473d0 /
c
c
      if (ido .eq. 2) then
         do k = 1, l1
            ti5 = cc(2,2,k) - cc(2,5,k)
            ti2 = cc(2,2,k) + cc(2,5,k)
            ti4 = cc(2,3,k) - cc(2,4,k)
            ti3 = cc(2,3,k) + cc(2,4,k)
            tr5 = cc(1,2,k) - cc(1,5,k)
            tr2 = cc(1,2,k) + cc(1,5,k)
            tr4 = cc(1,3,k) - cc(1,4,k)
            tr3 = cc(1,3,k) + cc(1,4,k)
            ch(1,k,1) = cc(1,1,k) + tr2 + tr3
            ch(2,k,1) = cc(2,1,k) + ti2 + ti3
            cr2 = cc(1,1,k) + tr11*tr2 + tr12*tr3
            ci2 = cc(2,1,k) + tr11*ti2 + tr12*ti3
            cr3 = cc(1,1,k) + tr12*tr2 + tr11*tr3
            ci3 = cc(2,1,k) + tr12*ti2 + tr11*ti3
            cr5 = ti11*tr5 + ti12*tr4
            ci5 = ti11*ti5 + ti12*ti4
            cr4 = ti12*tr5 - ti11*tr4
            ci4 = ti12*ti5 - ti11*ti4
            ch(1,k,2) = cr2 - ci5
            ch(1,k,5) = cr2 + ci5
            ch(2,k,2) = ci2 + cr5
            ch(2,k,3) = ci3 + cr4
            ch(1,k,3) = cr3 - ci4
            ch(1,k,4) = cr3 + ci4
            ch(2,k,4) = ci3 - cr4
            ch(2,k,5) = ci2 - cr5
         end do
      else
         do k = 1, l1
            do i = 2, ido, 2
               ti5 = cc(i,2,k) - cc(i,5,k)
               ti2 = cc(i,2,k) + cc(i,5,k)
               ti4 = cc(i,3,k) - cc(i,4,k)
               ti3 = cc(i,3,k) + cc(i,4,k)
               tr5 = cc(i-1,2,k) - cc(i-1,5,k)
               tr2 = cc(i-1,2,k) + cc(i-1,5,k)
               tr4 = cc(i-1,3,k) - cc(i-1,4,k)
               tr3 = cc(i-1,3,k) + cc(i-1,4,k)
               ch(i-1,k,1) = cc(i-1,1,k) + tr2 + tr3
               ch(i,k,1) = cc(i,1,k) + ti2 + ti3
               cr2 = cc(i-1,1,k) + tr11*tr2 + tr12*tr3
               ci2 = cc(i,1,k) + tr11*ti2 + tr12*ti3
               cr3 = cc(i-1,1,k) + tr12*tr2 + tr11*tr3
               ci3 = cc(i,1,k) + tr12*ti2 + tr11*ti3
               cr5 = ti11*tr5 + ti12*tr4
               ci5 = ti11*ti5 + ti12*ti4
               cr4 = ti12*tr5 - ti11*tr4
               ci4 = ti12*ti5 - ti11*ti4
               dr3 = cr3 - ci4
               dr4 = cr3 + ci4
               di3 = ci3 + cr4
               di4 = ci3 - cr4
               dr5 = cr2 + ci5
               dr2 = cr2 - ci5
               di5 = ci2 - cr5
               di2 = ci2 + cr5
               ch(i-1,k,2) = wa1(i-1)*dr2 + wa1(i)*di2
               ch(i,k,2) = wa1(i-1)*di2 - wa1(i)*dr2
               ch(i-1,k,3) = wa2(i-1)*dr3 + wa2(i)*di3
               ch(i,k,3) = wa2(i-1)*di3 - wa2(i)*dr3
               ch(i-1,k,4) = wa3(i-1)*dr4 + wa3(i)*di4
               ch(i,k,4) = wa3(i-1)*di4 - wa3(i)*dr4
               ch(i-1,k,5) = wa4(i-1)*dr5 + wa4(i)*di5
               ch(i,k,5) = wa4(i-1)*di5 - wa4(i)*dr5
            end do
         end do
      end if
      return
      end
c
c
c     ########################
c     ##                    ##
c     ##  subroutine passb  ##
c     ##                    ##
c     ########################
c
c
      subroutine passb (nac,ido,ip,l1,idl1,cc,c1,c2,ch,ch2,wa)
      implicit none
      integer nac,ido,ip,l1,idl1
      integer i,j,k,l,ik,jc,lc
      integer idj,idl,idp,idij,idlj
      integer inc,idot,nt,ipp2,ipph
      real*8 wai,war
      real*8 cc(ido,ip,l1)
      real*8 c1(ido,l1,ip)
      real*8 c2(idl1,ip)
      real*8 ch(ido,l1,ip)
      real*8 ch2(idl1,ip)
      real*8 wa(*)
c
c
      idot = ido / 2
      nt = ip * idl1
      ipp2 = ip + 2
      ipph = (ip+1) / 2
      idp = ip * ido
      if (ido .ge. l1) then
         do j = 2, ipph
            jc = ipp2 - j
            do k = 1, l1
               do i = 1, ido
                  ch(i,k,j) = cc(i,j,k) + cc(i,jc,k)
                  ch(i,k,jc) = cc(i,j,k) - cc(i,jc,k)
               end do
            end do
         end do
         do k = 1, l1
            do i = 1, ido
               ch(i,k,1) = cc(i,1,k)
            end do
         end do
      else
         do j = 2, ipph
            jc = ipp2 - j
            do i = 1, ido
               do k = 1, l1
                  ch(i,k,j) = cc(i,j,k) + cc(i,jc,k)
                  ch(i,k,jc) = cc(i,j,k) - cc(i,jc,k)
               end do
            end do
         end do
         do i = 1, ido
            do k = 1, l1
               ch(i,k,1) = cc(i,1,k)
            end do
         end do
      end if
      idl = 2 - ido
      inc = 0
      do l = 2, ipph
         lc = ipp2 - l
         idl = idl + ido
         do ik = 1, idl1
            c2(ik,l) = ch2(ik,1) + wa(idl-1)*ch2(ik,2)
            c2(ik,lc) = wa(idl) * ch2(ik,ip)
         end do
         idlj = idl
         inc = inc + ido
         do j = 3, ipph
            jc = ipp2 - j
            idlj = idlj + inc
            if (idlj .gt. idp)  idlj = idlj - idp
            war = wa(idlj-1)
            wai = wa(idlj)
            do ik = 1, idl1
               c2(ik,l) = c2(ik,l) + war*ch2(ik,j)
               c2(ik,lc) = c2(ik,lc) + wai*ch2(ik,jc)
            end do
         end do
      end do
      do j = 2, ipph
         do ik = 1, idl1
            ch2(ik,1) = ch2(ik,1) + ch2(ik,j)
         end do
      end do
      do j = 2, ipph
         jc = ipp2 - j
         do ik = 2, idl1, 2
            ch2(ik-1,j) = c2(ik-1,j) - c2(ik,jc)
            ch2(ik-1,jc) = c2(ik-1,j) + c2(ik,jc)
            ch2(ik,j) = c2(ik,j) + c2(ik-1,jc)
            ch2(ik,jc) = c2(ik,j) - c2(ik-1,jc)
         end do
      end do
      nac = 1
      if (ido .ne. 2) then
         nac = 0
         do ik = 1, idl1
            c2(ik,1) = ch2(ik,1)
         end do
         do j = 2, ip
            do k = 1, l1
               c1(1,k,j) = ch(1,k,j)
               c1(2,k,j) = ch(2,k,j)
            end do
         end do
         if (idot .le. l1) then
            idij = 0
            do j = 2, ip
               idij = idij + 2
               do i = 4, ido, 2
                  idij = idij + 2
                  do k = 1, l1
                     c1(i-1,k,j) = wa(idij-1)*ch(i-1,k,j)
     &                                - wa(idij)*ch(i,k,j)
                     c1(i,k,j) = wa(idij-1)*ch(i,k,j)
     &                              + wa(idij)*ch(i-1,k,j)
                  end do
               end do
            end do
         else
            idj = 2 - ido
            do j = 2, ip
               idj = idj + ido
               do k = 1, l1
                  idij = idj
                  do i = 4, ido, 2
                     idij = idij + 2
                     c1(i-1,k,j) = wa(idij-1)*ch(i-1,k,j)
     &                                - wa(idij)*ch(i,k,j)
                     c1(i,k,j) = wa(idij-1)*ch(i,k,j)
     &                              + wa(idij)*ch(i-1,k,j)
                  end do
               end do
            end do
         end if
      end if
      return
      end
c
c
c     #########################
c     ##                     ##
c     ##  subroutine passb2  ##
c     ##                     ##
c     #########################
c
c
      subroutine passb2 (ido,l1,cc,ch,wa1)
      implicit none
      integer i,k,ido,l1
      real*8 ti2,tr2
      real*8 cc(ido,2,l1)
      real*8 ch(ido,l1,2)
      real*8 wa1(*)
c
c
      if (ido .le. 2) then
         do k = 1, l1
            ch(1,k,1) = cc(1,1,k) + cc(1,2,k)
            ch(1,k,2) = cc(1,1,k) - cc(1,2,k)
            ch(2,k,1) = cc(2,1,k) + cc(2,2,k)
            ch(2,k,2) = cc(2,1,k) - cc(2,2,k)
         end do
      else
         do k = 1, l1
            do i = 2, ido, 2
               ch(i-1,k,1) = cc(i-1,1,k) + cc(i-1,2,k)
               tr2 = cc(i-1,1,k) - cc(i-1,2,k)
               ch(i,k,1) = cc(i,1,k) + cc(i,2,k)
               ti2 = cc(i,1,k) - cc(i,2,k)
               ch(i,k,2) = wa1(i-1)*ti2 + wa1(i)*tr2
               ch(i-1,k,2) = wa1(i-1)*tr2 - wa1(i)*ti2
            end do
         end do
      end if
      return
      end
c
c
c     #########################
c     ##                     ##
c     ##  subroutine passb3  ##
c     ##                     ##
c     #########################
c
c
      subroutine passb3 (ido,l1,cc,ch,wa1,wa2)
      implicit none
      integer i,k,ido,l1
      real*8 ti2,tr2,taur,taui
      real*8 ci2,ci3,cr2,cr3
      real*8 di2,di3,dr2,dr3
      real*8 cc(ido,3,l1)
      real*8 ch(ido,l1,3)
      real*8 wa1(*)
      real*8 wa2(*)
      data taur  / -0.5d0 /
      data taui  / 0.866025403784439d0 /
c
c
      if (ido .eq. 2) then
         do k = 1, l1
            tr2 = cc(1,2,k) + cc(1,3,k)
            cr2 = cc(1,1,k) + taur*tr2
            ch(1,k,1) = cc(1,1,k) + tr2
            ti2 = cc(2,2,k) + cc(2,3,k)
            ci2 = cc(2,1,k) + taur*ti2
            ch(2,k,1) = cc(2,1,k) + ti2
            cr3 = taui * (cc(1,2,k)-cc(1,3,k))
            ci3 = taui * (cc(2,2,k)-cc(2,3,k))
            ch(1,k,2) = cr2 - ci3
            ch(1,k,3) = cr2 + ci3
            ch(2,k,2) = ci2 + cr3
            ch(2,k,3) = ci2 - cr3
         end do
      else
         do k = 1, l1
            do i = 2, ido, 2
               tr2 = cc(i-1,2,k) + cc(i-1,3,k)
               cr2 = cc(i-1,1,k) + taur*tr2
               ch(i-1,k,1) = cc(i-1,1,k) + tr2
               ti2 = cc(i,2,k) + cc(i,3,k)
               ci2 = cc(i,1,k) + taur*ti2
               ch(i,k,1) = cc(i,1,k) + ti2
               cr3 = taui * (cc(i-1,2,k)-cc(i-1,3,k))
               ci3 = taui * (cc(i,2,k)-cc(i,3,k))
               dr2 = cr2 - ci3
               dr3 = cr2 + ci3
               di2 = ci2 + cr3
               di3 = ci2 - cr3
               ch(i,k,2) = wa1(i-1)*di2 + wa1(i)*dr2
               ch(i-1,k,2) = wa1(i-1)*dr2 - wa1(i)*di2
               ch(i,k,3) = wa2(i-1)*di3 + wa2(i)*dr3
               ch(i-1,k,3) = wa2(i-1)*dr3 - wa2(i)*di3
            end do
         end do
      end if
      return
      end
c
c
c     #########################
c     ##                     ##
c     ##  subroutine passb4  ##
c     ##                     ##
c     #########################
c
c
      subroutine passb4 (ido,l1,cc,ch,wa1,wa2,wa3)
      implicit none
      integer i,k,ido,l1
      real*8 ci2,ci3,ci4
      real*8 cr2,cr3,cr4
      real*8 ti1,ti2,ti3,ti4
      real*8 tr1,tr2,tr3,tr4
      real*8 cc(ido,4,l1)
      real*8 ch(ido,l1,4)
      real*8 wa1(*)
      real*8 wa2(*)
      real*8 wa3(*)
c
c
      if (ido .eq. 2) then
         do k = 1, l1
            ti1 = cc(2,1,k) - cc(2,3,k)
            ti2 = cc(2,1,k) + cc(2,3,k)
            tr4 = cc(2,4,k) - cc(2,2,k)
            ti3 = cc(2,2,k) + cc(2,4,k)
            tr1 = cc(1,1,k) - cc(1,3,k)
            tr2 = cc(1,1,k) + cc(1,3,k)
            ti4 = cc(1,2,k) - cc(1,4,k)
            tr3 = cc(1,2,k) + cc(1,4,k)
            ch(1,k,1) = tr2 + tr3
            ch(1,k,3) = tr2 - tr3
            ch(2,k,1) = ti2 + ti3
            ch(2,k,3) = ti2 - ti3
            ch(1,k,2) = tr1 + tr4
            ch(1,k,4) = tr1 - tr4
            ch(2,k,2) = ti1 + ti4
            ch(2,k,4) = ti1 - ti4
         end do
      else
         do k = 1, l1
            do i = 2, ido, 2
               ti1 = cc(i,1,k) - cc(i,3,k)
               ti2 = cc(i,1,k) + cc(i,3,k)
               ti3 = cc(i,2,k) + cc(i,4,k)
               tr4 = cc(i,4,k) - cc(i,2,k)
               tr1 = cc(i-1,1,k) - cc(i-1,3,k)
               tr2 = cc(i-1,1,k) + cc(i-1,3,k)
               ti4 = cc(i-1,2,k) - cc(i-1,4,k)
               tr3 = cc(i-1,2,k) + cc(i-1,4,k)
               ch(i-1,k,1) = tr2 + tr3
               cr3 = tr2 - tr3
               ch(i,k,1) = ti2 + ti3
               ci3 = ti2 - ti3
               cr2 = tr1 + tr4
               cr4 = tr1 - tr4
               ci2 = ti1 + ti4
               ci4 = ti1 - ti4
               ch(i-1,k,2) = wa1(i-1)*cr2 - wa1(i)*ci2
               ch(i,k,2) = wa1(i-1)*ci2 + wa1(i)*cr2
               ch(i-1,k,3) = wa2(i-1)*cr3 - wa2(i)*ci3
               ch(i,k,3) = wa2(i-1)*ci3 + wa2(i)*cr3
               ch(i-1,k,4) = wa3(i-1)*cr4 - wa3(i)*ci4
               ch(i,k,4) = wa3(i-1)*ci4 + wa3(i)*cr4
            end do
         end do
      end if
      return
      end
c
c
c     #########################
c     ##                     ##
c     ##  subroutine passb5  ##
c     ##                     ##
c     #########################
c
c
      subroutine passb5 (ido,l1,cc,ch,wa1,wa2,wa3,wa4)
      implicit none
      integer i,k,ido,l1
      real*8 ci2,ci3,ci4,ci5
      real*8 cr2,cr3,cr4,cr5
      real*8 di2,di3,di4,di5
      real*8 dr2,dr3,dr4,dr5
      real*8 ti2,ti3,ti4,ti5
      real*8 tr2,tr3,tr4,tr5
      real*8 tr11,ti11
      real*8 tr12,ti12
      real*8 cc(ido,5,l1)
      real*8 ch(ido,l1,5)
      real*8 wa1(*)
      real*8 wa2(*)
      real*8 wa3(*)
      real*8 wa4(*)
      data tr11  /  0.309016994374947d0 /
      data ti11  /  0.951056516295154d0 /
      data tr12  / -0.809016994374947d0 /
      data ti12  /  0.587785252292473d0 /
c
c
      if (ido .eq. 2) then
         do k = 1, l1
            ti5 = cc(2,2,k) - cc(2,5,k)
            ti2 = cc(2,2,k) + cc(2,5,k)
            ti4 = cc(2,3,k) - cc(2,4,k)
            ti3 = cc(2,3,k) + cc(2,4,k)
            tr5 = cc(1,2,k) - cc(1,5,k)
            tr2 = cc(1,2,k) + cc(1,5,k)
            tr4 = cc(1,3,k) - cc(1,4,k)
            tr3 = cc(1,3,k) + cc(1,4,k)
            ch(1,k,1) = cc(1,1,k) + tr2 + tr3
            ch(2,k,1) = cc(2,1,k) + ti2 + ti3
            cr2 = cc(1,1,k) + tr11*tr2 + tr12*tr3
            ci2 = cc(2,1,k) + tr11*ti2 + tr12*ti3
            cr3 = cc(1,1,k) + tr12*tr2 + tr11*tr3
            ci3 = cc(2,1,k) + tr12*ti2 + tr11*ti3
            cr5 = ti11*tr5 + ti12*tr4
            ci5 = ti11*ti5 + ti12*ti4
            cr4 = ti12*tr5 - ti11*tr4
            ci4 = ti12*ti5 - ti11*ti4
            ch(1,k,2) = cr2 - ci5
            ch(1,k,5) = cr2 + ci5
            ch(2,k,2) = ci2 + cr5
            ch(2,k,3) = ci3 + cr4
            ch(1,k,3) = cr3 - ci4
            ch(1,k,4) = cr3 + ci4
            ch(2,k,4) = ci3 - cr4
            ch(2,k,5) = ci2 - cr5
         end do
      else
         do k = 1, l1
            do i = 2, ido, 2
               ti5 = cc(i,2,k) - cc(i,5,k)
               ti2 = cc(i,2,k) + cc(i,5,k)
               ti4 = cc(i,3,k) - cc(i,4,k)
               ti3 = cc(i,3,k) + cc(i,4,k)
               tr5 = cc(i-1,2,k) - cc(i-1,5,k)
               tr2 = cc(i-1,2,k) + cc(i-1,5,k)
               tr4 = cc(i-1,3,k) - cc(i-1,4,k)
               tr3 = cc(i-1,3,k) + cc(i-1,4,k)
               ch(i-1,k,1) = cc(i-1,1,k) + tr2 + tr3
               ch(i,k,1) = cc(i,1,k) + ti2 + ti3
               cr2 = cc(i-1,1,k) + tr11*tr2 + tr12*tr3
               ci2 = cc(i,1,k) + tr11*ti2 + tr12*ti3
               cr3 = cc(i-1,1,k) + tr12*tr2 + tr11*tr3
               ci3 = cc(i,1,k) + tr12*ti2 + tr11*ti3
               cr5 = ti11*tr5 + ti12*tr4
               ci5 = ti11*ti5 + ti12*ti4
               cr4 = ti12*tr5 - ti11*tr4
               ci4 = ti12*ti5 - ti11*ti4
               dr3 = cr3 - ci4
               dr4 = cr3 + ci4
               di3 = ci3 + cr4
               di4 = ci3 - cr4
               dr5 = cr2 + ci5
               dr2 = cr2 - ci5
               di5 = ci2 - cr5
               di2 = ci2 + cr5
               ch(i-1,k,2) = wa1(i-1)*dr2 - wa1(i)*di2
               ch(i,k,2) = wa1(i-1)*di2 + wa1(i)*dr2
               ch(i-1,k,3) = wa2(i-1)*dr3 - wa2(i)*di3
               ch(i,k,3) = wa2(i-1)*di3 + wa2(i)*dr3
               ch(i-1,k,4) = wa3(i-1)*dr4 - wa3(i)*di4
               ch(i,k,4) = wa3(i-1)*di4 + wa3(i)*dr4
               ch(i-1,k,5) = wa4(i-1)*dr5 - wa4(i)*di5
               ch(i,k,5) = wa4(i-1)*di5 + wa4(i)*dr5
            end do
         end do
      end if
      return
      end


!===================================================================================
!=================== SUBROUTINE EULER ==============================================
!=================== DENSITY & VELOCITY  ===========================================

subroutine euler2coh(Nx,Ny,Nh,pi,time,nk,ukx,uky,nk_new,ukx_new,uky_new,dn_dt,dux_dt,duy_dt)
implicit none
integer ( kind = 4 ) Nx,Ny,Nh, i, j
real ( kind = 8 ) pi,time,dt,Lx,Ly,mux,muy,ms,CS
complex ( kind = 8 ) kNLn(Nh,Ny),kNLx(Nh,Ny),kNLy(Nh,Ny)
complex ( kind = 8 ) nk(Nh,Ny),ukx(Nh,Ny),uky(Nh,Ny),nk_new(Nh,Ny),ukx_new(Nh,Ny),uky_new(Nh,Ny)
complex ( kind = 8 ) dn_dt(Nh,Ny),dux_dt(Nh,Ny),duy_dt(Nh,Ny)
common/comm/Lx,Ly,mux,muy,ms,CS,dt

do i = 1,Nh
  do j = 1,Ny
    kNLn(i,j) = dn_dt(i,j)
    nk_new(i,j) = nk(i,j) + kNLn(i,j)*dt     ! EULER SOLVER
    kNLx(i,j) = dux_dt(i,j)
    ukx_new(i,j) = ukx(i,j) + kNLx(i,j)*dt     ! EULER SOLVER
    kNLy(i,j) = duy_dt(i,j)
    uky_new(i,j) = uky(i,j) + kNLy(i,j)*dt     ! EULER SOLVER
  end do
end do

return

end subroutine euler2coh


      SUBROUTINE spctrm(p,m,k,ovrlap,w1,w2)
      INTEGER k,m
      REAL p(m),w1(4*m),w2(m)
      LOGICAL ovrlap
CU    USES four1
      INTEGER j,j2,joff,joffn,kk,m4,m43,m44,mm
      REAL den,facm,facp,sumw,w,window
      window(j)=(1.-abs(((j-1)-facm)*facp))
C     window(j)=1.
C     window(j)=(1.-(((j-1)-facm)*facp)**2)
      mm=m+m
      m4=mm+mm
      m44=m4+4
      m43=m4+3
      den=0.
      facm=m
      facp=1./m
      sumw=0.
      do 11 j=1,mm
        sumw=sumw+window(j)**2
11    continue
      do 12 j=1,m
        p(j)=0.
12    continue
      if(ovrlap)then
        read (9,*) (w2(j),j=1,m)
      endif
      do 18 kk=1,k
        do 15 joff=-1,0,1
          if (ovrlap) then
            do 13 j=1,m
              w1(joff+j+j)=w2(j)
13          continue
            read (9,*) (w2(j),j=1,m)
            joffn=joff+mm
            do 14 j=1,m
              w1(joffn+j+j)=w2(j)
14          continue
          else
            read (9,*) (w1(j),j=joff+2,m4,2)
          endif
15      continue
        do 16 j=1,mm
          j2=j+j
          w=window(j)
          w1(j2)=w1(j2)*w
          w1(j2-1)=w1(j2-1)*w
16      continue
        call four1(w1,mm,1)
        p(1)=p(1)+w1(1)**2+w1(2)**2
        do 17 j=2,m
          j2=j+j
          p(j)=p(j)+w1(j2)**2+w1(j2-1)**2+w1(m44-j2)**2+w1(m43-j2)**2
17      continue
        den=den+sumw
18    continue
      den=m4*den
      do 19 j=1,m
        p(j)=p(j)/den
19    continue
      return
      END

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


c
c------------------------------------------------------------
c
       subroutine reg_slopes3(qavg,q,qx,qy,qxx,qxy,qyy,mitot,mjtot,irr,
     &                        lstgrd,lwidth,hx,hy,xlow,ylow,mptr,
     &                        nvar,istage)

       use amr_module
       implicit double precision(a-h,o-z)

       dimension q(nvar,mitot,mjtot),qx(nvar,mitot,mjtot),
     &           qy(nvar,mitot,mjtot),irr(mitot,mjtot)
       dimension qavg(nvar,mitot,mjtot)
       dimension qxx(nvar,mitot,mjtot), qyy(nvar,mitot,mjtot)
       dimension qxy(nvar,mitot,mjtot)
       logical  quad, nolimiter
       include "cuserdt.i"
       common /order2/ ssw, quad, nolimiter

c
c  Set all slopes, even for irregular or solid.
c  Will be fixed in slope routines for irregular/solid cells called afterwards

c      # ssw = slope switch (1. for slopes, 0 for donor cell 0 slopes)
c      # now set in amrcart
c
c   ssw = 0 for ctu (no slopes), 1 for muscl (second order).
c   compute slopes using muscl limiter
c   q contains either conserved or primitive variables
c
c  now set for quadratic reconstruction. Limiting done elsewhere
c  initialized to zero in method (in case no slopes at all)
c
c  this version converts to pointwise and then does pointwise derivatives
c  formulas should be high order quadratics

       q = qavg ! this will become pointwise vals
       hx2 = 2.d0*hx
       hy2 = 2.d0*hy
       hxsq = hx*hx
       hysq = hy*hy
c
c      compute second derivatives first since needed to convert
c      note that division by h^2 postponed til next loop
       do j = 2, mjtot-1
       do i = 2, mitot-1
          qxx(:,i,j) = q(:,i+1,j)-2.d0*q(:,i,j)+q(:,i-1,j)
          qyy(:,i,j) = q(:,i,j+1)-2.d0*q(:,i,j)+q(:,i,j-1)
          ! and while were at it, one more
          qxy(:,i,j) =  ((q(:,i+1,j+1) - q(:,i-1,j+1))
     &                 - (q(:,i+1,j-1) - q(:,i-1,j-1)))/(hx2*hy2)
       end do
       end do

       do j = 2, mjtot-1
       do i = 2, mitot-1
          q(:,i,j)  = q(:,i,j) -(qxx(:,i,j)+qyy(:,i,j))/24.d0
          qxx(:,i,j) = qxx(:,i,j)/hxsq
          qyy(:,i,j) = qyy(:,i,j)/hysq
       end do
       end do

       ! finally do gradients
       do j = 2, mjtot-1
       do i = 2, mitot-1
          qx(:,i,j) = (q(:,i+1,j)-q(:,i-1,j))/hx2
          qy(:,i,j) = (q(:,i,j+1)-q(:,i,j-1))/hy2
       end do
       end do

c
       return
       end


      REAL FUNCTION URAND(IY)
      INTEGER  IY
C
C      URAND IS A UNIFORM RANDOM NUMBER GENERATOR BASED  ON  THEORY  AND
C  SUGGESTIONS  GIVEN  IN  D.E. KNUTH (1969),  VOL  2.   THE INTEGER  IY
C  SHOULD BE INITIALIZED TO AN ARBITRARY INTEGER PRIOR TO THE FIRST CALL
C  TO URAND.  THE CALLING PROGRAM SHOULD  NOT  ALTER  THE  VALUE  OF  IY
C  BETWEEN  SUBSEQUENT CALLS TO URAND.  VALUES OF URAND WILL BE RETURNED
C  IN THE INTERVAL (0,1).
C
      INTEGER  IA,IC,ITWO,M2,M,MIC
      DOUBLE PRECISION  HALFM
      REAL  S
      DOUBLE PRECISION  DATAN,DSQRT
      DATA M2/0/,ITWO/2/
      IF (M2 .NE. 0) GO TO 20
C
C  IF FIRST ENTRY, COMPUTE MACHINE INTEGER WORD LENGTH
C
      M = 1
   10 M2 = M
      M = ITWO*M2
      IF (M .GT. M2) GO TO 10
      HALFM = M2
C
C  COMPUTE MULTIPLIER AND INCREMENT FOR LINEAR CONGRUENTIAL METHOD
C
      IA = 8*IDINT(HALFM*DATAN(1.D0)/8.D0) + 5
      IC = 2*IDINT(HALFM*(0.5D0-DSQRT(3.D0)/6.D0)) + 1
      MIC = (M2 - IC) + M2
C
C  S IS THE SCALE FACTOR FOR CONVERTING TO FLOATING POINT
C
      S = 0.5/HALFM
C
C  COMPUTE NEXT RANDOM NUMBER
C
   20 IY = IY*IA
C
C  THE FOLLOWING STATEMENT IS FOR COMPUTERS WHICH DO NOT ALLOW
C  INTEGER OVERFLOW ON ADDITION
C
      IF (IY .GT. MIC) IY = (IY - M2) - M2
C
      IY = IY + IC
C
C  THE FOLLOWING STATEMENT IS FOR COMPUTERS WHERE THE
C  WORD LENGTH FOR ADDITION IS GREATER THAN FOR MULTIPLICATION
C
      IF (IY/2 .GT. M2) IY = (IY - M2) - M2
C
C  THE FOLLOWING STATEMENT IS FOR COMPUTERS WHERE INTEGER
C  OVERFLOW AFFECTS THE SIGN BIT
C
      IF (IY .LT. 0) IY = (IY + M2) + M2
      URAND = FLOAT(IY)*S
      RETURN
      END


! { dg-do run }
! Tests the fix for pr31214, in which the typespec for the entry would be lost,
! thereby causing the function to be disallowed, since the function and entry
! types did not match.
!
! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
!
module type_mod
  implicit none

  type x
     real x
  end type x
  type y
     real x
  end type y
  type z
     real x
  end type z

  interface assignment(=)
     module procedure equals
  end interface assignment(=)

  interface operator(//)
     module procedure a_op_b, b_op_a
  end interface operator(//)

  interface operator(==)
     module procedure a_po_b, b_po_a
  end interface operator(==)

  contains
     subroutine equals(x,y)
        type(z), intent(in) :: y
        type(z), intent(out) :: x

        x%x = y%x
     end subroutine equals

     function a_op_b(a,b)
        type(x), intent(in) :: a
        type(y), intent(in) :: b
        type(z) a_op_b
        type(z) b_op_a
        a_op_b%x = a%x + b%x
        return
     entry b_op_a(b,a)
        b_op_a%x = a%x - b%x
     end function a_op_b

     function a_po_b(a,b)
        type(x), intent(in) :: a
        type(y), intent(in) :: b
        type(z) a_po_b
        type(z) b_po_a
     entry b_po_a(b,a)
        a_po_b%x = a%x/b%x
     end function a_po_b
end module type_mod

program test
  use type_mod
  implicit none
  type(x) :: x1 = x(19.0_4)
  type(y) :: y1 = y(7.0_4)
  type(z) z1

  z1 = x1//y1
  if (abs(z1%x - (19.0_4 + 7.0_4)) > epsilon(x1%x)) STOP 1
  z1 = y1//x1
  if (abs(z1%x - (19.0_4 - 7.0_4)) > epsilon(x1%x)) STOP 2

  z1 = x1==y1
  if (abs(z1%x - 19.0_4/7.0_4) > epsilon(x1%x)) STOP 3
  z1 = y1==x1
  if (abs(z1%x - 19.0_4/7.0_4) > epsilon(x1%x)) STOP 4
end program test


program ex

  use gabriel
  use MPI
  implicit none

  integer,parameter :: n=10
  integer,parameter :: s=2

  logical :: correct=.true.

  real,dimension(:,:),allocatable :: a,b
  integer ierr,rank,right,left,mpisize,i,j,k
  integer sz,r
  character :: szchar,aszchar
  type(distribution) :: d
  type(box) :: b1, b2
  call MPI_Init(ierr)
  call MPI_Comm_rank(MPI_COMM_WORLD,rank,ierr)
  call MPI_Comm_size(MPI_COMM_WORLD,mpisize,ierr)
  if (mpisize.gt.3)call MPI_Abort(MPI_COMM_WORLD,1,ierr)

  right=rank+1
  left=rank-1
  if (right.ge.mpisize)right=0
  if (left.lt.0)left=mpisize-1
  print*,'left,rank,right=',left,rank,right

  sz=mpisize*(mpisize+1)/2
  szchar=char(ichar('0')+sz)

  print*,sz,'=',szchar
  r=rank+1
  allocate(a((r-1)*r/2+1:(r+1)*r/2,sz))
  allocate(b(sz,(r-1)*r/2+1:(r+1)*r/2))
  aszchar=char(ichar('0')+size(a,1))
  print*,'shape(a),shape(b)=',shape(a),shape(b)
  print*,'lb(a),lb(b)=',lbound(a),lbound(b)
  print*,'ub(a),ub(b)=',ubound(a),ubound(b)
  a=0.0
  b=0.0
  do i=lbound(a,1),ubound(a,1)
  do j=lbound(a,2),ubound(a,2)
    a(i,j)=a(i,j)+i*0.1+j*0.01
  enddo
  enddo

  write(*,'(a,4i3)')'Size,Rank=',mpisize,rank

  write(*,'(a,i3,a,'//aszchar//'f8.3,2i5)')'BEFORE Rank',rank,' data=',a(:,1),lbound(a,1),ubound(a,1)
 print*,'BEFORE Rank',rank,' data=',a(lbound(a,1),:),lbound(a,2),ubound(a,2)

  print*,'Create compositions..'
  call b1%init(a,lbound(a),ubound(a),MPI_COMM_WORLD)
  call b2%init(b,lbound(b),ubound(b),MPI_COMM_WORLD)
  print*,'Create transform..'
  call d%transform(b1,b2)

  print*,'Transform decomposition..'
  call d%update(a,b)

!  write(*,'(a,i3,a,i4,4f13.3)')' AFTER Rank',rank,' data=',b(1,:)
  write(*,'(a,i3,a,'//szchar//'f8.3)')' AFTER Rank',rank,' data=',b(:,lbound(b,2))

  do i=lbound(b,1),ubound(b,1)
  do j=lbound(b,2),ubound(b,2)
    if (b(i,j).ne.i*0.1+j*0.01) correct=.false.
  enddo
  enddo

  deallocate(a,b)

  call MPI_Finalize(ierr)
  if (.not.correct) stop 1

end


program fixture
   use, intrinsic :: iso_fortran_env, only: wp => real64
   use json_module
   type(json_core) :: json
   type(json_value), pointer :: root
   double precision x(2), y(2), pi
   call json%initialize()
   call json%create_array(root, '')
   pi = 4.d0*datan(1.d0)

   x = (/1, 0/)
   y = (/0, 1/)
   call addcase(root, '0', 2, x, 1, y, 1, cos(pi*1.d0/6.d0), sin(pi*1.d0/6.d0))

   x = (/1, 0/)
   y = (/0, 1/)
   call addcase(root, '0', 2, x, -1, y, -1, cos(pi*1.d0/6.d0), sin(pi*1.d0/6.d0))

   x = (/1, 0/)
   y = (/0, 1/)
   call addcase(root, '0', 0, x, -1, y, -1, cos(pi*1.d0/6.d0), sin(pi*1.d0/6.d0))
   call print(root)
contains
   subroutine addcase(root, ncase, n, x, incx, y, incy, c, s)
      type(json_core) :: json
      type(json_value), pointer :: root, case, data
      external drot
      character(len=*) ncase
      integer n, incx, incy
      double precision x(2), y(2), c, s
      call json%create_object(case, '')
      call json%add(root, case)
      call json%add(case, 'n', n)
      call json%add(case, 'x', x)
      call json%add(case, 'incx', incx)
      call json%add(case, 'y', y)
      call json%add(case, 'incy', incy)
      call json%add(case, 'c', c)
      call json%add(case, 's', s)
      call drot(n, x, incx, y, incy, c, s)
      call json%create_object(data, 'expect')
      call json%add(data, 'x', x)
      call json%add(data, 'y', y)
      call json%add(case, data)
      nullify (data)
      nullify (case)
   end subroutine addcase

   subroutine print(root)
      use, intrinsic :: iso_fortran_env, only: real64
      use json_module, CK => json_CK
      implicit none

      type(json_core) :: json
      type(json_value), pointer :: root
      logical :: status_ok
      character(kind=CK, len=:), allocatable :: error_msg
      call json%print(root, './tests/fixtures/level1/rot.json')
      if (json%failed()) then
         call json%check_for_errors(status_ok, error_msg)
         write (*, *) 'Error: '//error_msg
         call json%clear_exceptions()
         call json%destroy(root)
      end if
   end subroutine print
end


      program non_linear04

C     Check non-linear expression handling

      if(i.lt.2.or.i.gt.10.or.j.lt.3.or.j.gt.11) stop

      k = i*(j-1)

      end


program main
  use mpi_f08
  use occa
  use, intrinsic :: iso_fortran_env, only : stdout=>output_unit, &
                                            stderr=>error_unit

  implicit none

  integer :: ierr, id
  integer :: myid, npes, tag ! MPI variables
  type(MPI_Comm) :: gcomm
  type(MPI_Request), dimension(2) :: request
  type(MPI_Status) :: status
  integer :: otherID, offset
  integer(occaUDim_t) :: iu
  integer(occaUDim_t) :: entries = 8
  character(len=1024), dimension(0:1) :: info
  real(C_float), dimension(0:1) :: ab_sum
  real(C_float) :: ab_gather

  real(C_float), allocatable, target :: a(:), b(:), ab(:)
  real(C_float), pointer :: ab_ptr(:)

  ! OCCA kernel, memory and property objects
  type(occaDevice)     :: device
  type(occaKernel)     :: addVectors
  type(occaMemory)     :: o_a, o_b, o_ab

  ! Initialise MPI
  gcomm = MPI_COMM_WORLD
  call MPI_Init(ierr)
  if (ierr /= MPI_SUCCESS) call stop_mpi("*** MPI_Init error ***")
  call MPI_Comm_rank(gcomm, myid,  ierr)
  call MPI_Comm_size(gcomm, npes,  ierr)
  if (npes /= 2) then
    call stop_mpi("*** Example expects to run with 2 processes ***", myid)
  end if

  ! Set OCCA device info
  !info = "{mode: 'Serial'}"
  info = "{mode: 'OpenMP', schedule: 'compact', chunk: 2}"

  ! Print device infos
  if(myid == 0) then
    call occaPrintModeInfo()
  endif
  call MPI_Barrier(gcomm, ierr)

  ! Allocate host memory
  allocate(a(1:entries), b(1:entries), ab(1:entries), stat=ierr)
  if (ierr /= 0) call stop_mpi("*** Not enough memory ***", myid)

  ! Initialise host arrays
  do iu=1,entries
    a(iu) = real(iu)-1
    b(iu) = myid-real(iu)
  end do
  ab = 0.0

  ! Create OCCA device
  device = occaCreateDeviceFromString(F_C_str(info(myid)))

  ! Allocate memory on the device
  o_a  = occaTypedMalloc(entries, occaDtypeFloat, C_NULL_ptr, occaDefault)
  o_b  = occaTypedMalloc(entries, occaDtypeFloat, C_NULL_ptr, occaDefault)
  o_ab = occaTypedMalloc(entries, occaDtypeFloat, C_NULL_ptr, occaDefault)

  ! Compile the kernel at run-time
  addVectors = occaBuildKernel(F_C_str("addVectors.okl"), &
                               F_C_str("addVectors"), &
                               occaDefault)

  ! Copy memory to the device
  call occaCopyPtrToMem(o_a, C_loc(a), entries*C_float, 0_occaUDim_t, occaDefault)
  call occaCopyPtrToMem(o_b, C_loc(b), occaAllBytes   , 0_occaUDim_t, occaDefault)

  ! Launch device kernel
  call occaKernelRun(addVectors, occaInt(entries), o_a, o_b, o_ab)

  ! Get a pointer to the device memory
  ! This only works if the device and host share a global address space, and
  ! thus only the 'Serial' and 'OpenMP' modes can be used. For an alternative
  ! implementation which works for other modes as well see the
  ! '11_mpi_unified_memory' example.
  if (occaDeviceHasSeparateMemorySpace(device)) then
    call stop_mpi("*** Example only works in 'Serial' and 'OpenMP' mode ***", myid)
  end if
  if (C_associated(occaMemoryPtr(o_ab, occaDefault))) then
    call C_F_pointer(occaMemoryPtr(o_ab, occaDefault),ab_ptr,[entries])
  else
    ab_ptr => null()
  end if

  ! Send/receive the result array
  otherID = mod(myid + 1, 2)
  offset  = int(entries/2)
  tag     = 123
  request = MPI_REQUEST_NULL
  call MPI_IRecv(ab_ptr(otherID*offset+1), &
                 offset, &
                 MPI_REAL4, &
                 otherID, &
                 tag, &
                 gcomm, &
                 request(1), &
                 ierr)
  call MPI_ISend(ab_ptr(myid*offset+1), &
                 offset, &
                 MPI_REAL4, &
                 otherID, &
                 tag, &
                 gcomm, &
                 request(2), &
                 ierr)
  call MPI_Wait(request(1), status, ierr)
  call MPI_Wait(request(2), status, ierr)

  ! Copy result to the host
  call occaCopyMemToPtr(C_loc(ab), o_ab, occaAllBytes, 0_occaUDim_t, occaDefault)

  ! Assert values
  call flush(stdout)
  ab_sum = myid
  ab_gather = sum(ab_ptr)
  call MPI_Gather(ab_gather, 1, MPI_REAL4, ab_sum, 1, MPI_REAL4, 0, gcomm, ierr)
  if (myid == 0) then
    if (abs(ab_sum(myid) - ab_sum(otherID)) > 1.0e-8) stop "*** Wrong result ***"
  end if

  ! Print values
  call flush(stdout)
  call MPI_Barrier(gcomm, ierr)
  do id=0,npes-1
    if (id == myid) then
      call flush(stdout)
      do iu=1,entries
      write(stdout,'(a,i1,a,i2,a,f5.1)') "#", id, ": ab(", iu, ") = ", ab_ptr(iu)
      call flush(stdout)
      end do
    end if
    call MPI_Barrier(gcomm, ierr)
  end do

  ! Free host memory
  deallocate(a, b, ab, stat=ierr)
  if (ierr /= 0) call stop_mpi("*** Deallocation not successful ***", myid)

  ! Free device memory and OCCA objects
  call occaFree(addVectors)
  call occaFree(o_a)
  call occaFree(o_b)
  call occaFree(o_ab)
  call occaFree(device)

  ! Cleanup MPI
  call MPI_Finalize(ierr)
  if (ierr /= MPI_SUCCESS) call stop_mpi("*** MPI_Finalize error ***", myid)

contains
  subroutine stop_mpi(error, myid, error_code)
    implicit none

    integer, intent(in), optional :: myid, error_code
    character(len=*), intent(in), optional :: error
    integer :: ierr, ec

    call flush(stdout)
    call MPI_Barrier(gcomm, ierr)

    if(present(error)) then
      if(present(myid)) then
        if(myid == 0) then
          write(stdout,'(a)') ''
          write(stdout,'(a)') error
          write(stdout,'(a)') ''
        end if
      else
        write(stdout,'(a)') ''
        write(stdout,'(a)') error
        write(stdout,'(a)') ''
      end if
    end if

    call flush(stdout)
    call MPI_Barrier(gcomm, ierr)

    if(present(error_code)) then
      ec = error_code
    else
      ec = -1
    end if

    call MPI_Abort(gcomm, ec, ierr)
  end subroutine
end program main


program ex3

    implicit none

    integer :: A(16)
    integer :: B(8,2)
    integer :: C(2,8)

    integer  :: i, j

    do i = 1, 16
        A(i) = i
    end do

    B = reshape(A, (/8, 2/))
    C = reshape(A, (/2, 8/))

end program ex3


submodule (stdlib_linalg) stdlib_linalg_diag

  implicit none

contains

      module function diag_rsp(v) result(res)
        real(sp), intent(in) :: v(:)
        real(sp) :: res(size(v),size(v))
        integer :: i
        res = 0
        do i = 1, size(v)
          res(i,i) = v(i)
        end do
      end function diag_rsp
      module function diag_rdp(v) result(res)
        real(dp), intent(in) :: v(:)
        real(dp) :: res(size(v),size(v))
        integer :: i
        res = 0
        do i = 1, size(v)
          res(i,i) = v(i)
        end do
      end function diag_rdp
      module function diag_rqp(v) result(res)
        real(qp), intent(in) :: v(:)
        real(qp) :: res(size(v),size(v))
        integer :: i
        res = 0
        do i = 1, size(v)
          res(i,i) = v(i)
        end do
      end function diag_rqp
      module function diag_csp(v) result(res)
        complex(sp), intent(in) :: v(:)
        complex(sp) :: res(size(v),size(v))
        integer :: i
        res = 0
        do i = 1, size(v)
          res(i,i) = v(i)
        end do
      end function diag_csp
      module function diag_cdp(v) result(res)
        complex(dp), intent(in) :: v(:)
        complex(dp) :: res(size(v),size(v))
        integer :: i
        res = 0
        do i = 1, size(v)
          res(i,i) = v(i)
        end do
      end function diag_cdp
      module function diag_cqp(v) result(res)
        complex(qp), intent(in) :: v(:)
        complex(qp) :: res(size(v),size(v))
        integer :: i
        res = 0
        do i = 1, size(v)
          res(i,i) = v(i)
        end do
      end function diag_cqp
      module function diag_iint8(v) result(res)
        integer(int8), intent(in) :: v(:)
        integer(int8) :: res(size(v),size(v))
        integer :: i
        res = 0
        do i = 1, size(v)
          res(i,i) = v(i)
        end do
      end function diag_iint8
      module function diag_iint16(v) result(res)
        integer(int16), intent(in) :: v(:)
        integer(int16) :: res(size(v),size(v))
        integer :: i
        res = 0
        do i = 1, size(v)
          res(i,i) = v(i)
        end do
      end function diag_iint16
      module function diag_iint32(v) result(res)
        integer(int32), intent(in) :: v(:)
        integer(int32) :: res(size(v),size(v))
        integer :: i
        res = 0
        do i = 1, size(v)
          res(i,i) = v(i)
        end do
      end function diag_iint32
      module function diag_iint64(v) result(res)
        integer(int64), intent(in) :: v(:)
        integer(int64) :: res(size(v),size(v))
        integer :: i
        res = 0
        do i = 1, size(v)
          res(i,i) = v(i)
        end do
      end function diag_iint64

      module function diag_rsp_k(v,k) result(res)
        real(sp), intent(in) :: v(:)
        integer, intent(in) :: k
        real(sp) :: res(size(v)+abs(k),size(v)+abs(k))
        integer :: i, sz
        sz = size(v)
        res = 0
        if (k > 0) then
          do i = 1, sz
              res(i,k+i) = v(i)
          end do
        else if (k < 0) then
          do i = 1, sz
              res(i+abs(k),i) = v(i)
          end do
        else
          do i = 1, sz
              res(i,i) = v(i)
          end do
        end if
      end function diag_rsp_k
      module function diag_rdp_k(v,k) result(res)
        real(dp), intent(in) :: v(:)
        integer, intent(in) :: k
        real(dp) :: res(size(v)+abs(k),size(v)+abs(k))
        integer :: i, sz
        sz = size(v)
        res = 0
        if (k > 0) then
          do i = 1, sz
              res(i,k+i) = v(i)
          end do
        else if (k < 0) then
          do i = 1, sz
              res(i+abs(k),i) = v(i)
          end do
        else
          do i = 1, sz
              res(i,i) = v(i)
          end do
        end if
      end function diag_rdp_k
      module function diag_rqp_k(v,k) result(res)
        real(qp), intent(in) :: v(:)
        integer, intent(in) :: k
        real(qp) :: res(size(v)+abs(k),size(v)+abs(k))
        integer :: i, sz
        sz = size(v)
        res = 0
        if (k > 0) then
          do i = 1, sz
              res(i,k+i) = v(i)
          end do
        else if (k < 0) then
          do i = 1, sz
              res(i+abs(k),i) = v(i)
          end do
        else
          do i = 1, sz
              res(i,i) = v(i)
          end do
        end if
      end function diag_rqp_k
      module function diag_csp_k(v,k) result(res)
        complex(sp), intent(in) :: v(:)
        integer, intent(in) :: k
        complex(sp) :: res(size(v)+abs(k),size(v)+abs(k))
        integer :: i, sz
        sz = size(v)
        res = 0
        if (k > 0) then
          do i = 1, sz
              res(i,k+i) = v(i)
          end do
        else if (k < 0) then
          do i = 1, sz
              res(i+abs(k),i) = v(i)
          end do
        else
          do i = 1, sz
              res(i,i) = v(i)
          end do
        end if
      end function diag_csp_k
      module function diag_cdp_k(v,k) result(res)
        complex(dp), intent(in) :: v(:)
        integer, intent(in) :: k
        complex(dp) :: res(size(v)+abs(k),size(v)+abs(k))
        integer :: i, sz
        sz = size(v)
        res = 0
        if (k > 0) then
          do i = 1, sz
              res(i,k+i) = v(i)
          end do
        else if (k < 0) then
          do i = 1, sz
              res(i+abs(k),i) = v(i)
          end do
        else
          do i = 1, sz
              res(i,i) = v(i)
          end do
        end if
      end function diag_cdp_k
      module function diag_cqp_k(v,k) result(res)
        complex(qp), intent(in) :: v(:)
        integer, intent(in) :: k
        complex(qp) :: res(size(v)+abs(k),size(v)+abs(k))
        integer :: i, sz
        sz = size(v)
        res = 0
        if (k > 0) then
          do i = 1, sz
              res(i,k+i) = v(i)
          end do
        else if (k < 0) then
          do i = 1, sz
              res(i+abs(k),i) = v(i)
          end do
        else
          do i = 1, sz
              res(i,i) = v(i)
          end do
        end if
      end function diag_cqp_k
      module function diag_iint8_k(v,k) result(res)
        integer(int8), intent(in) :: v(:)
        integer, intent(in) :: k
        integer(int8) :: res(size(v)+abs(k),size(v)+abs(k))
        integer :: i, sz
        sz = size(v)
        res = 0
        if (k > 0) then
          do i = 1, sz
              res(i,k+i) = v(i)
          end do
        else if (k < 0) then
          do i = 1, sz
              res(i+abs(k),i) = v(i)
          end do
        else
          do i = 1, sz
              res(i,i) = v(i)
          end do
        end if
      end function diag_iint8_k
      module function diag_iint16_k(v,k) result(res)
        integer(int16), intent(in) :: v(:)
        integer, intent(in) :: k
        integer(int16) :: res(size(v)+abs(k),size(v)+abs(k))
        integer :: i, sz
        sz = size(v)
        res = 0
        if (k > 0) then
          do i = 1, sz
              res(i,k+i) = v(i)
          end do
        else if (k < 0) then
          do i = 1, sz
              res(i+abs(k),i) = v(i)
          end do
        else
          do i = 1, sz
              res(i,i) = v(i)
          end do
        end if
      end function diag_iint16_k
      module function diag_iint32_k(v,k) result(res)
        integer(int32), intent(in) :: v(:)
        integer, intent(in) :: k
        integer(int32) :: res(size(v)+abs(k),size(v)+abs(k))
        integer :: i, sz
        sz = size(v)
        res = 0
        if (k > 0) then
          do i = 1, sz
              res(i,k+i) = v(i)
          end do
        else if (k < 0) then
          do i = 1, sz
              res(i+abs(k),i) = v(i)
          end do
        else
          do i = 1, sz
              res(i,i) = v(i)
          end do
        end if
      end function diag_iint32_k
      module function diag_iint64_k(v,k) result(res)
        integer(int64), intent(in) :: v(:)
        integer, intent(in) :: k
        integer(int64) :: res(size(v)+abs(k),size(v)+abs(k))
        integer :: i, sz
        sz = size(v)
        res = 0
        if (k > 0) then
          do i = 1, sz
              res(i,k+i) = v(i)
          end do
        else if (k < 0) then
          do i = 1, sz
              res(i+abs(k),i) = v(i)
          end do
        else
          do i = 1, sz
              res(i,i) = v(i)
          end do
        end if
      end function diag_iint64_k

      module function diag_rsp_mat(A) result(res)
        real(sp), intent(in) :: A(:,:)
        real(sp) :: res(minval(shape(A)))
        integer :: i
        do i = 1, minval(shape(A))
          res(i) = A(i,i)
        end do
      end function diag_rsp_mat
      module function diag_rdp_mat(A) result(res)
        real(dp), intent(in) :: A(:,:)
        real(dp) :: res(minval(shape(A)))
        integer :: i
        do i = 1, minval(shape(A))
          res(i) = A(i,i)
        end do
      end function diag_rdp_mat
      module function diag_rqp_mat(A) result(res)
        real(qp), intent(in) :: A(:,:)
        real(qp) :: res(minval(shape(A)))
        integer :: i
        do i = 1, minval(shape(A))
          res(i) = A(i,i)
        end do
      end function diag_rqp_mat
      module function diag_csp_mat(A) result(res)
        complex(sp), intent(in) :: A(:,:)
        complex(sp) :: res(minval(shape(A)))
        integer :: i
        do i = 1, minval(shape(A))
          res(i) = A(i,i)
        end do
      end function diag_csp_mat
      module function diag_cdp_mat(A) result(res)
        complex(dp), intent(in) :: A(:,:)
        complex(dp) :: res(minval(shape(A)))
        integer :: i
        do i = 1, minval(shape(A))
          res(i) = A(i,i)
        end do
      end function diag_cdp_mat
      module function diag_cqp_mat(A) result(res)
        complex(qp), intent(in) :: A(:,:)
        complex(qp) :: res(minval(shape(A)))
        integer :: i
        do i = 1, minval(shape(A))
          res(i) = A(i,i)
        end do
      end function diag_cqp_mat
      module function diag_iint8_mat(A) result(res)
        integer(int8), intent(in) :: A(:,:)
        integer(int8) :: res(minval(shape(A)))
        integer :: i
        do i = 1, minval(shape(A))
          res(i) = A(i,i)
        end do
      end function diag_iint8_mat
      module function diag_iint16_mat(A) result(res)
        integer(int16), intent(in) :: A(:,:)
        integer(int16) :: res(minval(shape(A)))
        integer :: i
        do i = 1, minval(shape(A))
          res(i) = A(i,i)
        end do
      end function diag_iint16_mat
      module function diag_iint32_mat(A) result(res)
        integer(int32), intent(in) :: A(:,:)
        integer(int32) :: res(minval(shape(A)))
        integer :: i
        do i = 1, minval(shape(A))
          res(i) = A(i,i)
        end do
      end function diag_iint32_mat
      module function diag_iint64_mat(A) result(res)
        integer(int64), intent(in) :: A(:,:)
        integer(int64) :: res(minval(shape(A)))
        integer :: i
        do i = 1, minval(shape(A))
          res(i) = A(i,i)
        end do
      end function diag_iint64_mat

      module function diag_rsp_mat_k(A,k) result(res)
        real(sp), intent(in) :: A(:,:)
        integer, intent(in) :: k
        real(sp) :: res(minval(shape(A))-abs(k))
        integer :: i, sz
        sz = minval(shape(A))-abs(k)
        if (k > 0) then
          do i = 1, sz
              res(i) = A(i,k+i)
          end do
        else if (k < 0) then
          do i = 1, sz
              res(i) = A(i+abs(k),i)
          end do
        else
          do i = 1, sz
              res(i) = A(i,i)
          end do
        end if
      end function diag_rsp_mat_k
      module function diag_rdp_mat_k(A,k) result(res)
        real(dp), intent(in) :: A(:,:)
        integer, intent(in) :: k
        real(dp) :: res(minval(shape(A))-abs(k))
        integer :: i, sz
        sz = minval(shape(A))-abs(k)
        if (k > 0) then
          do i = 1, sz
              res(i) = A(i,k+i)
          end do
        else if (k < 0) then
          do i = 1, sz
              res(i) = A(i+abs(k),i)
          end do
        else
          do i = 1, sz
              res(i) = A(i,i)
          end do
        end if
      end function diag_rdp_mat_k
      module function diag_rqp_mat_k(A,k) result(res)
        real(qp), intent(in) :: A(:,:)
        integer, intent(in) :: k
        real(qp) :: res(minval(shape(A))-abs(k))
        integer :: i, sz
        sz = minval(shape(A))-abs(k)
        if (k > 0) then
          do i = 1, sz
              res(i) = A(i,k+i)
          end do
        else if (k < 0) then
          do i = 1, sz
              res(i) = A(i+abs(k),i)
          end do
        else
          do i = 1, sz
              res(i) = A(i,i)
          end do
        end if
      end function diag_rqp_mat_k
      module function diag_csp_mat_k(A,k) result(res)
        complex(sp), intent(in) :: A(:,:)
        integer, intent(in) :: k
        complex(sp) :: res(minval(shape(A))-abs(k))
        integer :: i, sz
        sz = minval(shape(A))-abs(k)
        if (k > 0) then
          do i = 1, sz
              res(i) = A(i,k+i)
          end do
        else if (k < 0) then
          do i = 1, sz
              res(i) = A(i+abs(k),i)
          end do
        else
          do i = 1, sz
              res(i) = A(i,i)
          end do
        end if
      end function diag_csp_mat_k
      module function diag_cdp_mat_k(A,k) result(res)
        complex(dp), intent(in) :: A(:,:)
        integer, intent(in) :: k
        complex(dp) :: res(minval(shape(A))-abs(k))
        integer :: i, sz
        sz = minval(shape(A))-abs(k)
        if (k > 0) then
          do i = 1, sz
              res(i) = A(i,k+i)
          end do
        else if (k < 0) then
          do i = 1, sz
              res(i) = A(i+abs(k),i)
          end do
        else
          do i = 1, sz
              res(i) = A(i,i)
          end do
        end if
      end function diag_cdp_mat_k
      module function diag_cqp_mat_k(A,k) result(res)
        complex(qp), intent(in) :: A(:,:)
        integer, intent(in) :: k
        complex(qp) :: res(minval(shape(A))-abs(k))
        integer :: i, sz
        sz = minval(shape(A))-abs(k)
        if (k > 0) then
          do i = 1, sz
              res(i) = A(i,k+i)
          end do
        else if (k < 0) then
          do i = 1, sz
              res(i) = A(i+abs(k),i)
          end do
        else
          do i = 1, sz
              res(i) = A(i,i)
          end do
        end if
      end function diag_cqp_mat_k
      module function diag_iint8_mat_k(A,k) result(res)
        integer(int8), intent(in) :: A(:,:)
        integer, intent(in) :: k
        integer(int8) :: res(minval(shape(A))-abs(k))
        integer :: i, sz
        sz = minval(shape(A))-abs(k)
        if (k > 0) then
          do i = 1, sz
              res(i) = A(i,k+i)
          end do
        else if (k < 0) then
          do i = 1, sz
              res(i) = A(i+abs(k),i)
          end do
        else
          do i = 1, sz
              res(i) = A(i,i)
          end do
        end if
      end function diag_iint8_mat_k
      module function diag_iint16_mat_k(A,k) result(res)
        integer(int16), intent(in) :: A(:,:)
        integer, intent(in) :: k
        integer(int16) :: res(minval(shape(A))-abs(k))
        integer :: i, sz
        sz = minval(shape(A))-abs(k)
        if (k > 0) then
          do i = 1, sz
              res(i) = A(i,k+i)
          end do
        else if (k < 0) then
          do i = 1, sz
              res(i) = A(i+abs(k),i)
          end do
        else
          do i = 1, sz
              res(i) = A(i,i)
          end do
        end if
      end function diag_iint16_mat_k
      module function diag_iint32_mat_k(A,k) result(res)
        integer(int32), intent(in) :: A(:,:)
        integer, intent(in) :: k
        integer(int32) :: res(minval(shape(A))-abs(k))
        integer :: i, sz
        sz = minval(shape(A))-abs(k)
        if (k > 0) then
          do i = 1, sz
              res(i) = A(i,k+i)
          end do
        else if (k < 0) then
          do i = 1, sz
              res(i) = A(i+abs(k),i)
          end do
        else
          do i = 1, sz
              res(i) = A(i,i)
          end do
        end if
      end function diag_iint32_mat_k
      module function diag_iint64_mat_k(A,k) result(res)
        integer(int64), intent(in) :: A(:,:)
        integer, intent(in) :: k
        integer(int64) :: res(minval(shape(A))-abs(k))
        integer :: i, sz
        sz = minval(shape(A))-abs(k)
        if (k > 0) then
          do i = 1, sz
              res(i) = A(i,k+i)
          end do
        else if (k < 0) then
          do i = 1, sz
              res(i) = A(i+abs(k),i)
          end do
        else
          do i = 1, sz
              res(i) = A(i,i)
          end do
        end if
      end function diag_iint64_mat_k

end submodule


!-------------------------------------------------------------------------
!         NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
!-------------------------------------------------------------------------
!BOP
!
! !ROUTINE: zeit_jday() --- Returns the Julian day
!
      integer function zeit_jday ( CalDate )
!
! !INPUT PARAMETERS:
      implicit NONE
      integer  CalDate  ! Calendar date in the format YYYYMMDD
                        !   where YYYY is the year, MM is the
                        !   month and DD is the day.  A negative
                        !   number implies that the year is B.C.

*     Other variables
*     ---------------
      integer     Year
      integer     Month
      integer     Day
      integer     iGreg  ! Gregorian Calendar adopted Oct 12, 1582
      parameter ( iGreg = 15 + 31 * ( 10 + 12 * 1582 ) )
      integer     JulDay
      integer     jy, jm, ja

      Year   =       CalDate / 10000
      Month  = mod ( CalDate,  10000 ) / 100
      Day    = mod ( CalDate,    100 )

*     Change year 0 to year 1
*     -----------------------
      if ( Year  .eq. 0 ) Year = 1

*     Account for the nonexisting year 0
*     ----------------------------------
      if ( Year  .lt. 0 ) Year = Year + 1

      if ( Month .gt. 2 ) then
         jy = Year
         jm = Month + 1

      else
         jy = Year  - 1
         jm = Month + 13

      endif

      JulDay = int ( 365.25  * jy )
     .       + int ( 30.6001 * jm )
     .       + Day + 1720995

*     Test whether to change to Gregorian Celendar
*     --------------------------------------------
      if ( Day + 31 * ( Month + 12 * Year ) .ge. iGreg) then
        ja     = int ( 0.01 * jy )
        Julday = JulDay + 2 - ja + int ( 0.25 * ja )

      endif

      zeit_jday = JulDay

      return
      end


*     MB02ND EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      DOUBLE PRECISION ZERO
      PARAMETER        ( ZERO = 0.0D0 )
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          MMAX, NMAX, LMAX
      PARAMETER        ( MMAX = 20, NMAX = 20, LMAX = 20 )
      INTEGER          LDC, LDX
      PARAMETER        ( LDC = MAX( MMAX, NMAX+LMAX ), LDX = NMAX )
      INTEGER          LENGQ
      PARAMETER        ( LENGQ = 2*MIN(MMAX,NMAX+LMAX)-1 )
      INTEGER          LIWORK
      PARAMETER        ( LIWORK = NMAX+2*LMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = MAX(2, MAX( MMAX, NMAX+LMAX ) +
     $                            2*MIN( MMAX, NMAX+LMAX ),
     $                            MIN( MMAX, NMAX+LMAX ) +
     $                            MAX( ( NMAX+LMAX )*( NMAX+LMAX-1 )/2,
     $                              MMAX*( NMAX+LMAX-( MMAX-1 )/2 ) ) +
     $                            MAX( 6*(NMAX+LMAX)-5, LMAX*LMAX +
     $                                 MAX( NMAX+LMAX, 3*LMAX ) ) ) )
      INTEGER          LBWORK
      PARAMETER        ( LBWORK = NMAX+LMAX )
*     .. Local Scalars ..
      DOUBLE PRECISION RELTOL, THETA, THETA1, TOL
      INTEGER          I, INFO, IWARN, J, K, L, LOOP, M, MINMNL, N,
     $                 RANK, RANK1
*     .. Local Arrays ..
      DOUBLE PRECISION C(LDC,NMAX+LMAX), DWORK(LDWORK),
     $                 Q(LENGQ), X(LDX,LMAX)
      INTEGER          IWORK(LIWORK)
      LOGICAL          BWORK(LBWORK), INUL(NMAX+LMAX)
*     .. External Subroutines ..
      EXTERNAL         MB02ND
*     .. Intrinsic Functions ..
      INTRINSIC        MAX, MIN
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) M, N, L, RANK, THETA, TOL, RELTOL
      IF ( M.LT.0 .OR. M.GT.MMAX ) THEN
         WRITE ( NOUT, FMT = 99982 ) M
      ELSE IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99983 ) N
      ELSE IF ( L.LT.0 .OR. L.GT.LMAX ) THEN
         WRITE ( NOUT, FMT = 99981 ) L
      ELSE IF ( RANK.GT.MIN( MMAX, NMAX ) ) THEN
         WRITE ( NOUT, FMT = 99980 ) RANK
      ELSE IF ( RANK.LT.0 .AND. THETA.LT.ZERO ) THEN
         WRITE ( NOUT, FMT = 99979 ) THETA
      ELSE
         READ ( NIN, FMT = * ) ( ( C(I,J), J = 1,N+L ), I = 1,M )
         RANK1 = RANK
         THETA1 = THETA
*        Compute the solution to the TLS problem Ax = b.
         CALL MB02ND( M, N, L, RANK, THETA, C, LDC, X, LDX, Q, INUL,
     $                TOL, RELTOL, IWORK, DWORK, LDWORK, BWORK, IWARN,
     $                INFO )
*
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            IF ( IWARN.NE.0 ) THEN
               WRITE ( NOUT, FMT = 99997 ) IWARN
               WRITE ( NOUT, FMT = 99996 ) RANK
            ELSE
               IF ( RANK1.LT.0 ) WRITE ( NOUT, FMT = 99996 ) RANK
            END IF
            IF ( THETA1.LT.ZERO ) WRITE ( NOUT, FMT = 99995 ) THETA
            WRITE ( NOUT, FMT = 99994 )
            MINMNL = MIN( M, N+L )
            LOOP = MINMNL - 1
            DO 20 I = 1, LOOP
               K = I + MINMNL
               WRITE ( NOUT, FMT = 99993 ) I, I, Q(I), I, I + 1, Q(K)
   20       CONTINUE
            WRITE ( NOUT, FMT = 99992 ) MINMNL, MINMNL, Q(MINMNL)
            WRITE ( NOUT, FMT = 99991 )
            DO 60 J = 1, L
               DO 40 I = 1, N
                  WRITE ( NOUT, FMT = 99990 ) X(I,J)
   40          CONTINUE
               IF ( J.LT.L ) WRITE ( NOUT, FMT = 99989 )
   60       CONTINUE
            WRITE ( NOUT, FMT = 99987 ) N + L, N + L
            WRITE ( NOUT, FMT = 99985 )
            DO 80 I = 1, MAX( M, N + L )
               WRITE ( NOUT, FMT = 99984 ) ( C(I,J), J = 1,N+L )
   80       CONTINUE
            WRITE ( NOUT, FMT = 99986 )
            DO 100 J = 1, N + L
               WRITE ( NOUT, FMT = 99988 ) J, INUL(J)
  100       CONTINUE
         END IF
      END IF
      STOP
*
99999 FORMAT (' MB02ND EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MB02ND = ',I2)
99997 FORMAT (' IWARN on exit from MB02ND = ',I2,/)
99996 FORMAT (' The computed rank of the TLS approximation  = ',I3,/)
99995 FORMAT (' The computed value of THETA = ',F7.4,/)
99994 FORMAT (' The elements of the partially diagonalized bidiagonal ',
     $       'matrix are',/)
99993 FORMAT (2(' (',I1,',',I1,') = ',F7.4,2X))
99992 FORMAT (' (',I1,',',I1,') = ',F7.4,/)
99991 FORMAT (' The solution X to the TLS problem is ',/)
99990 FORMAT (1X,F8.4)
99989 FORMAT (' ')
99988 FORMAT (I3,L8)
99987 FORMAT (/' Right singular subspace corresponds to the first ',I2,
     $       ' components of the j-th ',/' column of C for which INUL(',
     $       'j) = .TRUE., j = 1,...,',I2,/)
99986 FORMAT (/'  j    INUL(j)',/)
99985 FORMAT (' Matrix C',/)
99984 FORMAT (20(1X,F8.4))
99983 FORMAT (/' N is out of range.',/' N = ',I5)
99982 FORMAT (/' M is out of range.',/' M = ',I5)
99981 FORMAT (/' L is out of range.',/' L = ',I5)
99980 FORMAT (/' RANK is out of range.',/' RANK = ',I5)
99979 FORMAT (/' THETA must be at least zero.',/' THETA = ',F8.4)
      END