C Copyright 1981-2012 ECMWF.
C
C This software is licensed under the terms of the Apache Licence 
C Version 2.0 which can be obtained at http://www.apache.org/licenses/LICENSE-2.0.
C
C In applying this licence, ECMWF does not waive the privileges and immunities 
C granted to it by virtue of its status as an intergovernmental organisation 
C nor does it submit to any jurisdiction.
C

      LOGICAL FUNCTION JACOBIF(DATA,NM,W,ROTANG)
C
C---->
C**** JACOBIF
C
C     Purpose
C     -------
C
C     Rotates spectral field by latitude (Fujitsu only).
C
C
C     Interface
C     ---------
C
C     IRET = JACOBIF(DATA,NM,W,ROTANG)
C
C     Input
C     -----
C
C     NM      - Triangular truncation number of the field.
C     DATA    - Linear array of REAL*8s of size (NM+1)*(NM+2)
C               holding the field.
C     W       - Work array of REAL*8s of size (NM+1)*(NM+2).
C     ROTANG  - Rotation angle (degrees, REAL*8)
C              (degrees, negative => rotate counter-clockwise about the
C                                    new Z-axis).
C     
C
C     Output
C     ------
C
C     DATA    - The transformed field.
C
C     Function returns .FALSE. if data cannot be transformed.
C
C
C     Method
C     ------
C
C     See reference paper below.
C
C     Coefficients are read into or are created in memory. A large
C     amount of memory may be required; eg, for truncation NM:
C       8*(NM*(2*NM*NM + 9*NM +13)/3) bytes.
C
C     Optionally, if the environment variable PP_SAVE_ROT is set, a
C     file of coefficients can be created in the directory given by
C     environment variable PP_ROT_DIR.
C
C     The name of the file of rotation coefficients indicates the
C     triangular truncation NM and the rotation angle ROTANG:
C
C           $PP_ROT_DIR/rot_coefs_Tttt_nnnnnnnnn
C     or    $TMPDIR/rot_coefs_Tttt_nnnnnnnnn
C
C     where:
C            ttt =  triangular truncation
C      nnnnnnnnn =  ROTANG*100000,
C     or
C           $PP_ROT_DIR/rot_coefs_Tttt_Mnnnnnnnn
C     or    $TMPDIR/rot_coefs_Tttt_Mnnnnnnnn
C
C     where:
C            ttt =  triangular truncation
C       nnnnnnnn =  -ROTANG*100000 if ROTANG is negative.
C        
C
C     Externals
C     ---------
C
C     INTLOG  - Logs messages.
C     INTLOGR - Logs messages.
C     GETENV  - To get environment variable data.
C     UNLINK  - To remove a file.
C     PPALLOW - Checks if the rotation coefficients can go into mrfs.
C
C
C     Author
C     ------
C
C     J.D.Chambers     ECMWF       April 1999
C
C
C     Reference.
C     ----------
C
C     "Spectral synthesis on rotated and regular grids"
C     by P.Lynch and R.McGrath (Irish Meteorological Service).
C
C
C----<
C     -----------------------------------------------------------------|
C
      IMPLICIT NONE
C
#include "jparams.h"
#include "parim.h"
C
C     Function arguments.
C
      REAL*8 DATA, W
      DIMENSION DATA(*), W(*)
      INTEGER NM
      REAL*8 ROTANG
C
C     Parameters.
C
      REAL*8 EPS
      PARAMETER(EPS = 1.0E-10)
      INTEGER JPNM_MAX, JPMAXMM, JPMEM20
      PARAMETER( JPNM_MAX = 640 )
      PARAMETER( JPMAXMM = 3 )
C                          `--> maximum number of memory slots
C                               used for rotation coefficients
      PARAMETER( JPMEM20 = 20 )
C                           `--> offset in memory allocation table of
C                                first memory slot for rotation
C                                coefficients
C
C     Local variables.
C
      LOGICAL LFOR, LALLOW
      INTEGER I, ISKIP, J, N, MM, K, IEND
      INTEGER NN, M, NDEX, IMEMORY
C
      REAL*4 SROTANG
      REAL*8 SIMAG, S, TEMP, DROTANG
      REAL*8 RAD, TANB, SINB, COSB, Q, RNKN, BNKN, SQNN
      REAL*8 SQNN1, SQ2N, PKN, PK1N, RNKN1, SREAL ,RNK0, RNK1
      REAL*8 INDEXR(JPNM_MAX), INDEXI(JPNM_MAX)
      REAL*8 MINUS1(JPNM_MAX)
      REAL*8 FACTOR(JPNM_MAX)
      REAL*8 WISQR(JPNM_MAX)
      REAL*8 WIB(JPNM_MAX)
      REAL*8 WIR(JPNM_MAX)
      REAL*8 WIDAT(2*JPNM_MAX)
C
      CHARACTER*256 FILENAME
      CHARACTER*40 COEFILE
      DATA COEFILE/'rot_coefs_Tnnn_nnnnnnnnn'/
C
      INTEGER IUNIT, IRET, ILAT, OLDLAT(3), OLDTRUN(3), IOFFSET
      INTEGER IFSIZE, ICNDEX
      INTEGER LOOP, NMP1TM, MAXMEM
      LOGICAL LINMEM, LEXIST
C
      INTEGER CURRENT, OLDEST
      DATA OLDEST/1/, MAXMEM/JPMAXMM/
      SAVE OLDEST, MAXMEM
C
      DATA OLDLAT/3*9999999/, OLDTRUN/3*0/
      DATA LINMEM/.FALSE./, LEXIST/.FALSE./
      SAVE IUNIT, ILAT, OLDLAT, OLDTRUN, COEFILE, LINMEM, LEXIST
C
#ifdef POINTER_64
Cjdc  INTEGER*8 ICOEFF
#endif
      REAL*8 ACOEFF
      DIMENSION ACOEFF(1)
      POINTER ( ICOEFF, ACOEFF )
C
C     Externals
C
      INTEGER JCHMOD, UNLINK
      LOGICAL PPALLOW
      EXTERNAL JCHMOD, UNLINK, PPALLOW
C
C     Statement function
C
      REAL*8 A, B
      LOGICAL ABSCHK
      ABSCHK(A,B) = (ABS(A-B) .LT. EPS*(ABS(A) + ABS(B)))
C
C     W array: 1 -> (NM+1)*(NM+2) for PMN/SQRT(2*N+1) values.
C
C     RNKM values in WIR (for M>0),
C                 in WIB (M<0).
C     Array of temporary SQRT values in WISQR, and
C     temporary transformed data in WIDAT
C
C     -----------------------------------------------------------------|
C*    Section 1.   Initialise
C     -----------------------------------------------------------------|
C
  100 CONTINUE
C
      JACOBIF = .FALSE.
C
      LALLOW = PPALLOW(NM,ROTANG)
C
      CALL INTLOG(JP_DEBUG,'JACOBIF: truncation = ', NM)
      SROTANG = SNGL(ROTANG)
      CALL INTLOGR(JP_DEBUG,'JACOBIF: rotation angle = ', SROTANG)
C
C     Exit immediately if rotation angle is zero.
C
      IF (ABS(ROTANG).LT.EPS) THEN
        CALL INTLOG(JP_DEBUG,'JACOBIF: No rotation necessary',JPQUIET)
        JACOBIF = .TRUE.
        GOTO 999
      ENDIF
C
C     Change to radians.
C
      RAD   = 180.0/PPI
      DROTANG = ROTANG/RAD
      TANB  = TAN(DROTANG/(2.0))
      SINB  = SIN(DROTANG)
      COSB  = COS(DROTANG)
      Q     = SQRT(2.0)/2.0
C
      ICNDEX = 0
C
C     -----------------------------------------------------------------|
C*    Section 2.   Generate PMN/SQRT(2*N+1) values in W.
C     -----------------------------------------------------------------|
C
  200 CONTINUE
C
      W(1)  = 1.0
      W(2)  = COSB
C
      ISKIP = NM + 1
!OCL SCALAR
      DO I = 1,ISKIP
        W(1+ISKIP*I)   = W(1+ISKIP*I-ISKIP)*SINB*
     X                   SQRT(DBLE(2*I-1)/DBLE(2*I))
        W(1+ISKIP*I+1) = COSB*DSQRT(DBLE(2*I+1))*W(1+ISKIP*I)
      ENDDO
C
!OCL SCALAR
      DO I = 2,ISKIP-1
C
!OCL VECTOR
        DO J = 0,ISKIP-I+1
          FACTOR(J) = 1.0/DSQRT(DBLE((I+2*J)*I))
        ENDDO
C
        DO J = 0,ISKIP-I+1
          W(I+J*ISKIP+1) = COSB*DBLE(2*I+2*J-1)
     X                     *FACTOR(J)*W(I+J*ISKIP)
     X                     - DSQRT(DBLE((I-1)*(I+2*J-1)))
     X                     *FACTOR(J)*W(I+J*ISKIP-1)
        ENDDO
C
      ENDDO
C
      MINUS1(1) = -1
!OCL SCALAR
      DO I = 2, JPNM_MAX
        MINUS1(I) = -MINUS1(I-1)
      ENDDO
C
C     -----------------------------------------------------------------|
C*    Section 3.   Pick up the rotation coefficients RNKM.
C     -----------------------------------------------------------------|
C
  300 CONTINUE
C
C     Change the interpolation coefficents if the input latitude is
C     not the same as the one used the last time through.
C
      ILAT = NINT(ROTANG*100000)
C
      DO LOOP = 1, MAXMEM
        IF( ILAT.EQ.OLDLAT(LOOP).AND.(OLDTRUN(LOOP).EQ.NM) ) THEN
C
C         Set flags to show the rotation coefficients are in memory
C
          LINMEM = .TRUE.
          LEXIST = .TRUE.
          CURRENT = LOOP + JPMEM20 - 1
          CALL INTLOG(JP_DEBUG,
     X      'JACOBIF: Existing memory slot re-used = ', CURRENT)
          CALL JMEMHAN( CURRENT, ICOEFF, IMEMORY, 1, IRET)
          IF( IRET.NE.0 ) THEN
            CALL INTLOG(JP_FATAL,
     X        'JACOBIF: Failed to pick up existing memory pool',CURRENT)
            JACOBIF = .FALSE.
            GOTO 999
          ENDIF
          GOTO 310
        ENDIF
      ENDDO
C
      LINMEM = .FALSE.
      LEXIST = .FALSE.
      CURRENT = OLDEST + JPMEM20 - 1
      OLDLAT(OLDEST)  = ILAT
      OLDTRUN(OLDEST) = NM
      OLDEST  = OLDEST + 1
      IF( OLDEST.GT.MAXMEM ) OLDEST = 1
      CALL INTLOG(JP_DEBUG,
     X  'JACOBIF: Different memory slot selected = ', CURRENT)
C
  310 CONTINUE
C
      IF( .NOT. LINMEM ) THEN
C
C       Calculate the coefficients file size (coefficients are REAL*8)
C
        IFSIZE = 8*(NM*(2*NM*NM + 9*NM +13)/3)
C
C       Allocate memory for the REAL*8 coefficients
C
#ifdef REAL_8
        IMEMORY = (NM*(2*NM*NM + 9*NM +13)/3)
#else
        IMEMORY = 2*(NM*(2*NM*NM + 9*NM +13)/3)
#endif
C
  320   CONTINUE
C
        CALL JMEMHAN( CURRENT, ICOEFF, IMEMORY, 1, IRET)
        IF( IRET.NE.0 ) THEN
C
C         If memory allocation fails, reduce the number of slots in the
C         memory pool. Exit if the pool is already down to one slot.
C
          IF( MAXMEM.LT.2 ) THEN
            CALL INTLOG(JP_FATAL,
     X        'JACOBIF: memory allocation error',ICOEFF)
            JACOBIF = .FALSE.
            GOTO 999
          ENDIF
          MAXMEM = MAXMEM - 1
          CALL INTLOG(JP_DEBUG,
     X      'JACOBIF: Reduce number of memory slots to ', MAXMEM)
          LINMEM = .FALSE.
          LEXIST = .FALSE.
          OLDEST = 1
          OLDLAT(OLDEST)  = ILAT
          OLDTRUN(OLDEST) = NM
          CURRENT = OLDEST + JPMEM20 - 1
          OLDEST = OLDEST + 1
          IF( OLDEST.GT.MAXMEM ) OLDEST = 1
          CALL INTLOG(JP_DEBUG,
     X      'JACOBIF: Different memory slot selected = ', CURRENT)
          GOTO 320
        ENDIF
        ICNDEX = 0
C
C       If the file already exists, read it into memory.
C       For 'standard' rotations try PP_ROT_DIR, otherwise TMPDIR.
C
        IF( LALLOW ) THEN
          CALL GETENV('PP_ROT_DIR',FILENAME)
        ELSE
          CALL GETENV('TMPDIR',FILENAME)
        ENDIF
        IOFFSET = INDEX(FILENAME,' ')
        IF( IOFFSET.EQ.1) THEN
          CALL INTLOG(JP_WARN,
     X      'JACOBIF: Unable to open rotation coefficents.',JPQUIET)
C
        ELSE
C
          CALL INTLOG(JP_DEBUG,
     X      'JACOBIF: Existing coefficients sought in:',JPQUIET)
          CALL INTLOG(JP_DEBUG,
     X      'JACOBIF: '// FILENAME(1:IOFFSET-1),JPQUIET)
C
          WRITE(COEFILE(12:14),'(I3.3)') NM
          IF( ILAT.GE.0) THEN
            WRITE(COEFILE(16:),'(I9.9)') ILAT
          ELSE
            COEFILE(16:) = 'M'
            WRITE(COEFILE(17:),'(I8.8)') -ILAT
          ENDIF
          FILENAME = FILENAME(1:IOFFSET-1) // '/' // COEFILE
          IOFFSET = INDEX(FILENAME,' ') - 1
C
          CALL PBOPEN(IUNIT,FILENAME(1:IOFFSET),'r',IRET)
          IF( IRET.EQ.0 ) THEN
C
C           Let user know that a existing file has been opened
C
            CALL INTLOG(JP_DEBUG,
     X        'JACOBIF: Existing coefficients found in file:',JPQUIET)
            CALL INTLOG(JP_DEBUG,'JACOBIF: '// COEFILE, JPQUIET)
C
C           Read coefficients into memory
C
            CALL PBREAD(IUNIT,ACOEFF,IFSIZE,IRET)
            IF( IRET.NE.IFSIZE ) THEN
              CALL INTLOG(JP_WARN,'JACOBIF: PBREAD failed.',JPQUIET)
            ELSE
C
C           Set flags to show the rotation coefficients are in memory
C           and exist.
C
              LINMEM = .TRUE.
              LEXIST = .TRUE.
            ENDIF
C
            CALL PBCLOSE(IUNIT,IRET)
          ENDIF
C
        ENDIF
C
      ENDIF
C
C     -----------------------------------------------------------------|
C*    Section 4.   Generate the rotation coefficients RNKM.
C     -----------------------------------------------------------------|
C
  400 CONTINUE
C
C
C     Generate the rotation coefficients RNKM (K = M dashed in note)
C     and store in W.  For K = 0 special case.
C
C     PMN = W(M*(NM+1) + (N-M+1))
C
!OCL VECTOR
      DO 630 N = 1,NM
        RNKN  = (0.5*(1.0 + COSB))**N
        BNKN  = (0.5*(1.0 - COSB))**N
        SQNN  = DSQRT(DBLE((N+1)*N))
        SQNN1 = SQNN*SINB
        SQ2N  = DSQRT(2.0/DBLE(N))/SINB
C
C       Save SQRTS.
C
!OCL VECTOR
        DO MM = 0,N
          WISQR(MM+1) = DSQRT(DBLE((N+MM)*(N-MM+1)))*SINB
        ENDDO
C
        NN = 1
C
C       Generate RNKM, M = 0 to N.
C
!OCL SCALAR
        DO 590 K = N,0,-1
C
C         If the coefficients are not (yet) in memory, they have to
C         be calculated.
C
          IF( .NOT. LINMEM ) THEN
C
            PKN = W(K*(NM+1) + (N-K+1))
            IF (K.EQ.0) GOTO 500
C
C           For K > 0, go forward from zero.
C
            PK1N = W((K-1)*(NM+1) + (N-(K-1)+1))
C
C           Flip sign if necessary.
C
            IF (MOD(K,2).NE.0)THEN
              PKN = -PKN
            ELSE
              PK1N = -PK1N
            ENDIF
C
C           Work using forward recurrence as long as coefficient
C           calculated passes checks.
C
            LFOR = .TRUE.
C
            RNK0 = PKN
            RNK1 = (-DBLE(K)*TANB*PKN + (WISQR(K+1)/SINB)*PK1N)/SQNN
C
C           Recurrence starts at 2 for M = 0
C
            WIR(1) = RNK0
            WIR(2) = RNK1
C
!OCL SCALAR
            DO MM = 1,N-1
              WIR(MM+2) = (2.0*WIR(MM+1)*(DBLE(MM)*COSB-DBLE(K))
     X                    - WISQR(MM+1)*WIR(MM)) /WISQR(MM+2)
C
C             Apply check to generated coefficient to see if its
C             absolute value is greater than 1.  If so, have to
C             switch to using backwards recurrences.
C
              IF (ABS(WIR(MM+2)).GT.1.0)THEN
                LFOR = .FALSE.
                IEND = MM + 3
                GOTO 435
              ENDIF
            ENDDO
C
C           If forward recurrence appears OK so far,
C           test last element RNKN by comparing with WIR(N+1).
C
            IEND = N + 2
            IF (ABSCHK(RNKN,WIR(N+1))) GOTO 445
C
C           If test failed, try generating coefficients using
C           backwards recurrences.
C
  435       CONTINUE
C
C           Work backwards from the top.
C           Specify N; K is already set from the loop above.
C           Stop at M = 1 (NOT 0).
C
            RNKN1 = RNKN*SQ2N*(DBLE(N)*COSB-DBLE(K))
            WIR(N+1) = RNKN
C
C           Check whether difference is within prescribed tolerance.
C
            IF (LFOR .AND. ABSCHK(RNKN1,WIR(N))) GO  TO 445
            WIR(N) = RNKN1
C
C           For M = 0:
C
!OCL SCALAR
            DO MM = N-1,1,-1
              S = (2.0*WIR(MM+1)*(DBLE(MM)*COSB-DBLE(K))
     X              - (WISQR(MM+2)*WIR(MM+2))) / WISQR(MM+1)
C
C             Accept these if forward recursion failed before
C             reaching this point.
C
              IF (MM+1.LT.IEND)THEN
                IF (ABSCHK(S,WIR(MM))) GOTO 445
              ENDIF
              WIR(MM) = S
C
C             If absolute value is greater than 1, give up gracefully
C
              IF (ABS(S).GT.1.0) GOTO 920
C
            ENDDO
C
            GOTO 920
C
  445       CONTINUE
C
C           Now RNKM for M = 0,-N
C
C           RNKM M = -1,-N
C
C           Forward recurrence starts at 1 for M = 0, 2 for -1 etc.
C
            LFOR = .TRUE.
C
            WIB(1) = RNK0
            WIB(2) = -RNK1-RNK0*DBLE(2*K)/(SQNN1)
C
!OCL SCALAR
            DO MM = 1,(N-1)
              WIB(MM+2) = (2.0*WIB(MM+1)*(DBLE(-MM)*COSB-DBLE(K))
     X              - WISQR(MM+1)*SINB*WIB(MM)) /WISQR(MM+2)
C
C             Apply check to generated coefficient to see if its
C             absolute value is greater than 1.  If so, have to
C             switch to using backwards recurrences.
C
              IF (ABS(WIB(MM+2)).GT.1.0)THEN
                LFOR = .FALSE.
                IEND = MM + 3
                GOTO 455
              ENDIF
            ENDDO
C
C           If forward recurrence appears OK so far,
C           test last element BNKN by comparing with WIB(N+1).
C
            IEND = N + 1
            IF (ABSCHK(BNKN,WIB(N+1))) GOTO 500
C
C           If test failed, try generating coefficients using backwards
C           recurrences.
C
  455       CONTINUE
C
C           Get R values.
C           First RNKN, then next highest RNKN1.
C
            RNKN1 = -BNKN*SQ2N*(DBLE(N)*COSB + DBLE(K))
C
C           Work backwards from the top.
C           Specify N; K is already set from the loop above.
C
C           Stop at M = 1 (NOT 0).
C
            WIB(N+1) = BNKN
            IF (LFOR .AND. ABSCHK(RNKN1,WIB(N))) GOTO 500
            WIB(N) = RNKN1
C
!OCL SCALAR
            DO MM = N-1,1,-1
              S = (2.0*WIB(MM+1)*(DBLE(-MM)*COSB-DBLE(K))
     X            - (WISQR(MM+2)*WIB(MM+2))) / WISQR(MM+1)
C
C             Accept backwards generated coefficients if forward
C             recursion failed before reaching this point.
C
              IF ( (MM.LT.IEND ) .AND. ABSCHK(S,WIB(MM)) ) GOTO 500
              WIB(MM) = S
C
C             If absolute value is greater than 1, give up.
C
              IF (ABS(S).GT.1.0) GOTO 910
C
            ENDDO
C
C           End of backwards recurrences reached with no agreed
C           coefficients, give up.
C
            GOTO 910
C
C     -----------------------------------------------------------------|
C*    Section 5.   Got RNKM. Now transform spectral data.
C     -----------------------------------------------------------------|
C
  500       CONTINUE
C
C           Put coefficients in allocated memory
C
!OCL VECTOR
            DO LOOP = 1, N+1
              ACOEFF(ICNDEX    +LOOP) = WIR(LOOP)
              ACOEFF(ICNDEX+N+1+LOOP) = WIB(LOOP)
            ENDDO
C
          ENDIF
C
C         Coefficients are in memory
C
          PKN  = W(K*(NM+1) + (N-K+1))
          PK1N = W((K-1)*(NM+1) + (N-(K-1)+1))
C
C         Flip sign if necessary.
C
          IF (MOD(K,2).NE.0)THEN
            PKN  = -PKN
          ELSE
            PK1N = -PK1N
          ENDIF
C
!OCL VECTOR
          DO LOOP = 1, N+1
            WIR(LOOP) = ACOEFF(ICNDEX    +LOOP)
            WIB(LOOP) = ACOEFF(ICNDEX+N+1+LOOP)
          ENDDO
          ICNDEX = ICNDEX + 2*(N+1)
C
C
C         Special case when K=0.
C
          IF( K.EQ.0) THEN
C
            SREAL = DATA(2*(N+1)-1)*PKN
            SIMAG = 0.0
!OCL VECTOR
            DO M = 1,N
              SREAL = SREAL
     X        + 2.0*DATA(2*((NM+1)*M-((M-1)*M)/2+1+N-M)-1)
     X        * W((NM+1)*M+(N-M+1))
            ENDDO
C
            NDEX       = 1+N
            WIDAT(NN)   = SREAL
            WIDAT(NN+1) = SIMAG
            NN          = NN + 2
C
          ELSE
C
            SREAL  = DATA(2*(N+1)-1)*PKN
            SIMAG  = 0.0
!OCL VECTOR
            DO M = 1,N
              INDEXR(M) = 2*((NM+1)*M-((M-1)*M)/2+1+N-M)-1
            ENDDO
!OCL VECTOR
            DO M = 1,N
              INDEXI(M) = INDEXR(M) + 1
            ENDDO
C
!OCL VECTOR
            DO M = 1,N
              SREAL = SREAL +
     X              DATA(INDEXR(M))
     X              * (WIR(M+1)+WIB(M+1)*MINUS1(M))
              SIMAG = SIMAG -
     X              DATA(INDEXI(M))
     X              * (-WIR(M+1)+WIB(M+1)*MINUS1(M))
            ENDDO
C
            NDEX       = (NM+1)*K - ((K-1)*K)/2+1+N-K
            WIDAT(NN)   = SREAL
            WIDAT(NN+1) = SIMAG
            NN          = NN + 2
          ENDIF
C
C         Update RNKN at both ends of the forward and backward
C         recurrences.
C
          TEMP = DSQRT(DBLE(N+K)/DBLE(N-K+1))
          RNKN = RNKN*TEMP*SINB/(1+COSB)
          BNKN = -BNKN*TEMP*(1+COSB)/SINB
C
C       End of inner loop.
C
  590   CONTINUE
C
C     -----------------------------------------------------------------|
C*    Section 6.   Now place the values of the rotated spectral
C                  coefficients in DATA.
C     -----------------------------------------------------------------|
C
  600 CONTINUE
C
        NN = 1
!OCL VECTOR
        DO K = N,0,-1
          NDEX = (NM+1)*K - ((K-1)*K)/2+1+N-K
          DATA(2*NDEX-1) = WIDAT(NN)
          DATA(2*NDEX)   = WIDAT(NN+1)
          NN = NN + 2
C
        ENDDO
C
C     End of outer loop.
C
  630 CONTINUE
C
C     -----------------------------------------------------------------|
C*    Section 9.   Return.
C     -----------------------------------------------------------------|
C
  900 CONTINUE
C
      LINMEM = .TRUE.
C
      IF( .NOT. LEXIST ) THEN
C
C       If the environment variable PP_SAVE_ROT is set, save the
C       rotation coefficients in a file.
C       'Standard' rotations go into PP_ROT_DIR, others into TMPDIR.
C
        LEXIST = .TRUE.
        CALL GETENV('PP_SAVE_ROT',FILENAME)
        IOFFSET = INDEX(FILENAME,' ')
        IF( IOFFSET.GT.1 ) THEN
          IF( LALLOW ) THEN
            CALL GETENV('PP_ROT_DIR',FILENAME)
          ELSE
            CALL GETENV('TMPDIR',FILENAME)
          ENDIF
          IOFFSET = INDEX(FILENAME,' ')
          IF( IOFFSET.EQ.1) THEN
            CALL INTLOG(JP_WARN,
     X        'JACOBIF: Unable to save rotation coefficents.',JPQUIET)
C
          ELSE
C
C         Let user know that a new file is being created.
C
          CALL INTLOG(JP_DEBUG,
     X      'JACOBIF: Creating new coefficients in directory',JPQUIET)
          CALL INTLOG(JP_DEBUG,
     X      'JACOBIF: '// FILENAME(1:IOFFSET-1),JPQUIET)
C
            WRITE(COEFILE(12:14),'(I3.3)') NM
            IF( ILAT.GE.0) THEN
              WRITE(COEFILE(16:),'(I9.9)') ILAT
            ELSE
              COEFILE(16:) = 'M'
              WRITE(COEFILE(17:),'(I8.8)') -ILAT
            ENDIF
            FILENAME = FILENAME(1:IOFFSET-1) // '/' // COEFILE
            IOFFSET = INDEX(FILENAME,' ')
C
            CALL PBOPEN(IUNIT,FILENAME(1:IOFFSET-1),'w',IRET)
            IF( IRET.NE.0 ) THEN
              CALL INTLOG(JP_WARN,
     X          'JACOBIF: PBOPEN for write failed',JPQUIET)
              GOTO 995
            ENDIF
C
            CALL INTLOG(JP_DEBUG,
     X        'JACOBIF: New coefficients filename:',JPQUIET)
            CALL INTLOG(JP_DEBUG,'JACOBIF: '// COEFILE, JPQUIET)
C
C           Change access mode to 'read only' for all users.
C
            IRET = JCHMOD(FILENAME(1:IOFFSET-1),'0444')
            IF( IRET.NE.0 )
     X        CALL INTLOG(JP_WARN,'JACOBIF: JCHMOD error.',IRET)
C
C           Write coefficients to file
C
            CALL PBWRITE(IUNIT,ACOEFF,IFSIZE,IRET)
            IF( IRET.NE.IFSIZE ) THEN
              CALL INTLOG(JP_FATAL,'JACOBIF: PBWRITE failed.',JPQUIET)
              IRET = UNLINK(FILENAME(1:IOFFSET-1))
              IF( IRET.NE.0 )
     X          CALL INTLOG(JP_FATAL,'JACOBIF: UNLINK failed',JPQUIET)
              CALL PBCLOSE(IUNIT,IRET)
              JACOBIF = .FALSE.
              GOTO 999
            ENDIF
            CALL PBCLOSE(IUNIT,IRET)
            LINMEM = .TRUE.
          ENDIF
        ENDIF
      ENDIF
C
  995 CONTINUE
C
      JACOBIF = .TRUE.
C
  999 CONTINUE
      RETURN
C
C     Failure to converge with M < 0.
C
  910 CONTINUE
      CALL INTLOG(JP_FATAL,'JACOBIF: Fail to converge M < 0', JPQUIET)
      JACOBIF = .FALSE.
      GOTO 999
C
C     Failure to converge with M > 0.
C
  920 CONTINUE
      CALL INTLOG(JP_FATAL,'JACOBIF: Fail to converge M > 0', JPQUIET)
      JACOBIF = .FALSE.
      GOTO 999
      END
