C Copyright 1981-2007 ECMWF
C 
C Licensed under the GNU Lesser General Public License which
C incorporates the terms and conditions of version 3 of the GNU
C General Public License.
C See LICENSE and gpl-3.0.txt for details.
C

      INTEGER FUNCTION IGTRAN (PMAT, KINCOL, KINROW, KMOVE, KLEN,
     1   KPR, KERR)
C
C---->
C**** *IGTRAN*
C
C     PURPOSE
C     _______
C
C     This routine transposes a rectangular matrix.
C
C     INTERFACE
C     _________
C
C     IERR = IGTRAN (PMAT, KINCOL, KINROW, KMOVE, KLEN, KPR, KERR)
C
C     Input parameters
C     ________________
C
C     PMAT       - The input matrix of length KINCOL * KINROW.
C
C     KINCOL     - The length of the first dimension on entry and
C                  second dimension on exit.
C
C     KINROW     - The length of the second dimension on entry and
C                  first dimension on exit.
C
C     KMOVE      - Work array used to store information to speed up
C                  the process.
C
C     KLEN       - Length of array KMOVE. The recommended length is
C                  (KINCOL + KINROW) / 2.
C
C     KPR        - The debug print switch.
C                  0  , No debugging output.
C                  1  , Produce debugging output.
C
C     KERR       - The error control flag.
C                  (No longer used, kept for backward compatibility.
C                   Used to be used as follows:
C                  -ve, No error message. Return error code.
C                  0  , Hard failure with error message.
C                  +ve, Print error message. Return error code.)
C
C     Output parameters
C     ________________
C
C     PMAT       - The transposed matrix.
C
C     Return value
C     ____________
C
C     The error indicator (INTEGER).
C
C     7401  KLEN was less than 1.
C     7402  A failure during transposition (should never happen).
C
C
C     Common block usage
C     __________________
C
C     None
C
C     EXTERNALS
C     _________
C
C     INTLOG     - Generate log messages.
C
C
C     METHOD
C     ______
C
C     This algorithm uses the cyclic structure of transposition to
C     perform a transposition in place with a minimum amount of work
C     storage.
C
C     REFERENCE
C     _________
C
C     Esko G. Cate and David W. Twigg      Analysis of In-Situ
C                                          Transposition
C     CACM Algorithm 513
C
C
C     COMMENTS
C     ________
C
C     None.
C
C
C     AUTHOR
C     ______
C
C     K. Fielding      *ECMWF*      Jan 1994
C
C
C     MODIFICATIONS
C     _____________
C
C     J.D.Chambers      ECMWF       Sept 1995
C
C----<
C     _______________________________________________________
C
      IMPLICIT NONE
C
#include "parim.h"
C
C     Function arguments
C
      INTEGER KINCOL, KINROW, KLEN, KPR, KERR
      INTEGER KMOVE(KLEN)
      REAL PMAT (KINCOL * KINROW)
C
C     Local variables
      INTEGER ICOUNT, IRMULC, IR0, IR1, IR2, IPOINT, IKMI, IP1, IP2,
     X   IRMCM1, IP1C, IP2C, IROWP1, ICOLM1, ISTART
      INTEGER JST, JINROW, JINCOL
      REAL ZMIP1, ZMIP1C, ZTEMP
C
C     Parameters
      INTEGER JPROUTINE
      PARAMETER (JPROUTINE = 7400)
C
C     _______________________________________________________
C
C*    Section 1. Initialisation
C     _______________________________________________________
C
  100 CONTINUE
C
      IF (KPR .GE. 1) CALL INTLOG(JP_DEBUG,'IGTRAN: Section 1.',JPQUIET)
C
      IGTRAN = 0
C
      IF (KPR .GE. 1) THEN
        CALL INTLOG(JP_DEBUG,'IGTRAN: Input parameters.',JPQUIET)
        CALL INTLOG(JP_DEBUG,'IGTRAN: 1st matrix dimension = ',KINCOL)
        CALL INTLOG(JP_DEBUG,'IGTRAN: 2nd matrix dimension = ',KINROW)
        CALL INTLOG(JP_DEBUG,'IGTRAN: Work array length = ',KLEN)
        CALL INTLOG(JP_DEBUG,
     X    'IGTRAN: Recommended length = ',(KINCOL + KINROW) / 2)
      ENDIF
C
      IF (KINCOL .LE. 1 .OR. KINROW .LE. 1) GO TO 900
C
C     _______________________________________________________
C
C*    Section 2. Rectangular transposition setup
C     _______________________________________________________
C
  200 CONTINUE
C
      IF (KPR .GE. 1) CALL INTLOG(JP_DEBUG,'IGTRAN: Section 2.',JPQUIET)
C
      IF (KINCOL .NE. KINROW) THEN
C
        IF (KLEN .LT. 1) THEN
          IGTRAN = JPROUTINE + 1
          CALL INTLOG(JP_ERROR,'IGTRAN: Work array size = ',KLEN)
          CALL INTLOG(JP_ERROR,'IGTRAN: Must be at least 1.',JPQUIET)
          GO TO 900
        ENDIF
C
        ICOUNT = 2
        IRMULC = KINCOL * KINROW
        IRMCM1 = IRMULC - 1
C
        DO 210 JST = 1, KLEN
          KMOVE (JST) = 0
  210   CONTINUE
C
        IF (KINCOL .GT. 2 .AND. KINROW .GT. 2) THEN
C
C         Calculate the number of fixed points, Euclids algorithm
C         for GCD (m - 1, n - 1)
C
          IR2 = KINCOL - 1
          IR1 = KINROW - 1
C
  220     CONTINUE
          IR0 = MOD (IR2, IR1)
          IR2 = IR1
          IR1 = IR0
          IF (IR0 .NE. 0) GO TO 220
C
          ICOUNT = ICOUNT + IR2 - 1
C
        ENDIF
C
C       Set initial values for search
C
        ISTART = 1
        IPOINT = KINCOL
C
C       At least one loop must be rearranged so branch into loop
C
        GO TO 330
C
C     _______________________________________________________
C
C*    Section 3. Rectangular transposition main loop
C     _______________________________________________________
C
  310   CONTINUE
C
C       Search for loops to rearrange
C
        IKMI = IRMCM1 - ISTART
        ISTART = ISTART + 1
C
        IF (ISTART .GT. IKMI) THEN
          IGTRAN = JPROUTINE + 2
          CALL INTLOG(JP_ERROR,
     X        'IGTRAN: Fail during transposition.',JPQUIET)
          GO TO 900
        ENDIF
C
        IPOINT = IPOINT + KINCOL
C
        IF (IPOINT .GT. IRMCM1) IPOINT = IPOINT - IRMCM1
C
        IP2 = IPOINT
C
        IF (ISTART .EQ. IP2) GO TO 310
C
        IF (ISTART .GT. KLEN) THEN
C
  320     CONTINUE
C
C         Loop exit condition
C
          IF (IP2 .LE. ISTART .OR. IP2 .GE. IKMI)  THEN
            IF (IP2 .NE. ISTART) THEN
              GO TO 310
            ELSE
              GO TO 330
            ENDIF
          ENDIF
          IP1 = IP2
          IP2 = KINCOL * IP1 - IRMCM1 * (IP1 / KINROW)
          GO TO 320
        ENDIF
C
        IF (KMOVE (ISTART) .NE. 0) GO TO 310
C
C       Rearrange the elements of a loop and its companion loop
C
C       Entry into loop on first pass
C
  330   CONTINUE
C
        IP1 = ISTART
        IKMI = IRMCM1 - ISTART
        ZMIP1 = PMAT (IP1 + 1)
        IP1C = IKMI
        ZMIP1C = PMAT (IP1C + 1)
C
  340   CONTINUE
        IP2 = KINCOL * IP1 - IRMCM1 * (IP1 / KINROW)
        IP2C = IRMCM1 - IP2
C
        IF (IP1 .LE. KLEN) KMOVE (IP1) = 2
        IF (IP1C .LE. KLEN) KMOVE (IP1C) = 2
C
        ICOUNT = ICOUNT + 2
C
C       Loop exit conditions
C
        IF (IP2 .EQ. ISTART) GO TO 360
        IF (IP2 .EQ. IKMI) GO TO 350
C
        PMAT (IP1 + 1) = PMAT(IP2 + 1)
        PMAT (IP1C + 1) = PMAT(IP2C + 1)
        IP1 = IP2
        IP1C = IP2C
C
        GO TO 340
C
  350   CONTINUE
C
        ZTEMP = ZMIP1
        ZMIP1 = ZMIP1C
        ZMIP1C = ZTEMP
C
  360   CONTINUE
C
        PMAT (IP1 + 1) = ZMIP1
        PMAT (IP1C + 1) = ZMIP1C
C
        IF (ICOUNT .LT. IRMULC) GO TO 310
C
      ELSE
C
C     _______________________________________________________
C
C*    Section 4. Square transposition
C     _______________________________________________________
C
  400 CONTINUE
C
        IF (KPR.GE.1) CALL INTLOG(JP_DEBUG,'IGTRAN: Section 4.',JPQUIET)
C
C       Square matrix so exchange elements a(i,j) and a(j,i)
C
        ICOLM1 = KINCOL - 1
C
        DO 420 JINCOL = 1, ICOLM1
C
          IROWP1 = JINCOL + 1
C
          DO 410 JINROW = IROWP1, KINROW
C
            IP1 = JINCOL + (JINROW - 1) * KINCOL
            IP2 = JINROW + (JINCOL - 1) * KINROW
C
            ZTEMP = PMAT (IP1)
            PMAT (IP1) = PMAT (IP2)
            PMAT (IP2) = ZTEMP
C
  410     CONTINUE
  420   CONTINUE
      ENDIF
C
C     _______________________________________________________
C
C*    Section 9. Return to calling routine. Format statements
C     _______________________________________________________
C
  900 CONTINUE
C
      IF (KPR .GE. 1) CALL INTLOG(JP_DEBUG,'IGTRAN: Section 9.',JPQUIET)
C
      RETURN
      END
