C--------------------------------------------------------------------
C This tests the handling of actual argument remapping by the caller
C due to an explicit interface, assumed shape dummy arguments
C (both in interfaces and procedure definitions), and descriptive
C mapping directives.
C--------------------------------------------------------------------
      SUBROUTINE AD_MAIN ()
        IMPLICIT INTEGER (I-K), REAL (R-T), DOUBLE PRECISION (D-F), COMP
     *LEX (X-Z), CHARACTER (A-C), LOGICAL (L-N)
        
        INTEGER :: K_MA (0:24)
        
        INTEGER, DIMENSION (0:3, 0:1) :: I_A
        INTEGER, DIMENSION (0:1) :: K_PP
        
        EXTERNAL  O_REMAP_AND_DBL        
        LOGICAL  N_FIRSTCALL
        DATA     N_FIRSTCALL /.TRUE./
        INTEGER  ::  K_Q, K_H0, K_H1, K_H2, K_H3, K_H4, K_H5, K_H6, K_H7
     *, K_P0, K_P1 (0:0), K_P2 (0:1), K_P3 (0:2), K_P4 (0:3), K_P5 (0:4)
     *, K_P6 (0:5), K_P7 (0:6)
        COMMON /Q_PROCS/ K_Q, K_H0, K_H1, K_H2, K_H3, K_H4, K_H5, K_H6, 
     *K_H7, K_P0, K_P1, K_P2, K_P3, K_P4, K_P5, K_P6, K_P7
        
        INTEGER           ::  K_PTR, K_Z, K_TMP (0 : 299999)
        REAL              ::  T_TMP (0 : 299999)
        DOUBLE PRECISION  ::  F_TMP (0 : 149999)
        COMPLEX           ::  Z_TMP (0 : 149999)
        LOGICAL           ::  N_TMP (0 : 299999)
        EQUIVALENCE (K_TMP, T_TMP, F_TMP, Z_TMP, N_TMP)
        COMMON /Q_STACK/ K_PTR, K_Z, K_TMP
        
        K_PTR = 0
        
        CALL AD_INIT_PROCS (K_H1, 1, (/1/))
        CALL AD_PROC_COORD (K_H1, K_P1)
        CALL AD_INIT_PROCS (K_H2, 2, (/1, 1/))
        CALL AD_PROC_COORD (K_H2, K_P2)
        CALL AD_INIT_PROCS (K_H3, 3, (/1, 1, 1/))
        CALL AD_PROC_COORD (K_H3, K_P3)
        CALL AD_INIT_PROCS (K_H4, 4, (/1, 1, 1, 1/))
        CALL AD_PROC_COORD (K_H4, K_P4)
        CALL AD_INIT_PROCS (K_H5, 5, (/1, 1, 1, 1, 1/))
        CALL AD_PROC_COORD (K_H5, K_P5)
        CALL AD_INIT_PROCS (K_H6, 6, (/1, 1, 1, 1, 1, 1/))
        CALL AD_PROC_COORD (K_H6, K_P6)
        CALL AD_INIT_PROCS (K_H7, 7, (/1, 1, 1, 1, 1, 1, 1/))
        CALL AD_PROC_COORD (K_H7, K_P7)
        CALL AD_INIT_PROCS (K_HP, 2, (/2, 2/))
        CALL AD_PROC_COORD (K_HP, K_PP)
        
        K_MA = (/66, 0, K_HP, 0, 0, 4, 4, 1, 1, 4, 2, 2, 7, 4, 4, 1, -2,
     * 8, 8, 4, 4, 2, 2, 0, 1/)
        
        DO 10 I_I = 1, 4
          DO 20 I_J = 1, 4
            IF (K_PP(0) == (I_I+1)/4 .AND. K_PP(1) == (-(I_J-1)*2+7)/4) 
     *THEN
              K_V0 = MOD(I_I+1,4)
              K_V1 = MOD(-(I_J-1)*2+7,4)/2
              I_A (K_V0,K_V1) = I_I+I_J*10
            ENDIF
            
   20     CONTINUE
   10   CONTINUE
        IF (K_P0 == 0) THEN
          PRINT '(" main:  initially...")'
        ENDIF
        K_T0 = K_PTR;   K_PTR = K_PTR + 16
        IF (K_PTR .GT. 300000) CALL AD_STACK_ERR (300000)
        K_M0 = K_PTR;   K_PTR = K_PTR + 26
        IF (K_PTR .GT. 300000) CALL AD_STACK_ERR (300000)
        K_TMP (K_M0 : K_M0+24) = (/258, 0, K_H0, 0, 0, 4, 4, 1, 1, 4, 4,
     * 0, 0, 4, 4, 1, 1, 4, 4, 4, 4, 1, 1, -1, -1/)
        
        CALL AD_REMAP_II (K_TMP(K_T0), K_TMP(K_M0), I_A, K_MA)
        
        IF (K_P0 == 0) THEN
          PRINT '(4i5)', K_TMP(K_T0:K_T0+(15))
        ENDIF
        K_PTR = K_PTR - 42
        DO 30 I_I = 1, 2
          K_T0 = K_PTR;   K_PTR = K_PTR + 16
          IF (K_PTR .GT. 300000) CALL AD_STACK_ERR (300000)
          K_M0 = K_PTR;   K_PTR = K_PTR + 26
          IF (K_PTR .GT. 300000) CALL AD_STACK_ERR (300000)
          K_TMP (K_M0 : K_M0+24) = (/66, 0, K_HP, 0, 0, 4, 4, 1, 1, 4, 4
     *, 2, 1, 4, 4, 1, 2, 8, 8, 4, 1, 2, 4, 0, 1/)
          
          K_T1 = K_PTR;   K_PTR = K_PTR + 16
          IF (K_PTR .GT. 300000) CALL AD_STACK_ERR (300000)
          K_M1 = K_PTR;   K_PTR = K_PTR + 26
          IF (K_PTR .GT. 300000) CALL AD_STACK_ERR (300000)
          K_TMP (K_M1 : K_M1+24) = (/8258, 0, K_HP, 0, 0, 4, 4, 1, 1, 4,
     * 4, 2, 1, 4, 4, 1, 2, 8, 8, 4, 1, 2, 4, 0, 1/)
          
          CALL AD_REMAP_II (K_TMP(K_T1), K_TMP(K_M1), I_A, K_MA)
          
          CALL O_REMAP_AND_DBL (K_TMP(K_T0), K_TMP(K_M0), K_TMP(K_T1), K
     *_TMP(K_M1), 2)
          K_PTR = K_PTR - 42
          
          K_T1 = K_PTR;   K_PTR = K_PTR + 8
          IF (K_PTR .GT. 300000) CALL AD_STACK_ERR (300000)
          CALL AD_REMAP_II (K_TMP(K_T1), K_MA, K_TMP(K_T0), K_TMP(K_M0))
          
          K_V0 = K_PP(0)*4
          K_V1 = MAX(-K_V0+2,0)
          K_V2 = K_PP(1)*4
          K_V3 = MAX(-(K_V2-5)/2,0)
          K_V4 = (-K_V2-K_V3*2+7)/2
          K_V5 = MIN(-K_V0+5,3)
          K_V6 = MAX(-K_V2+1,0)/2
          K_T1_1 = K_T1 + (K_V1+K_V4*4)
          DO K_1 = K_V4, K_V6, -1
            K_T1_0 = K_T1_1
            DO K_0 = K_V1, K_V5
              I_A (K_0,K_1) = K_TMP (K_T1_0)
              K_T1_0 = K_T1_0 + (1)
            ENDDO
            K_T1_1 = K_T1_1 + (-4)
          ENDDO
          
          K_PTR = K_PTR - 50
          IF (K_P0 == 0) THEN
            PRINT *
          ENDIF
          IF (K_P0 == 0) THEN
            PRINT '(" main:  after call to remap_and_dbl...")'
          ENDIF
          K_T0 = K_PTR;   K_PTR = K_PTR + 16
          IF (K_PTR .GT. 300000) CALL AD_STACK_ERR (300000)
          K_M0 = K_PTR;   K_PTR = K_PTR + 26
          IF (K_PTR .GT. 300000) CALL AD_STACK_ERR (300000)
          K_TMP (K_M0 : K_M0+24) = (/258, 0, K_H0, 0, 0, 4, 4, 1, 1, 4, 
     *4, 0, 0, 4, 4, 1, 1, 4, 4, 4, 4, 1, 1, -1, -1/)
          
          CALL AD_REMAP_II (K_TMP(K_T0), K_TMP(K_M0), I_A, K_MA)
          
          IF (K_P0 == 0) THEN
            PRINT '(4i5)', K_TMP(K_T0:K_T0+(15))
          ENDIF
          K_PTR = K_PTR - 42
   30   CONTINUE
        CALL AD_DELETE_PROCS (K_HP)
        
        CALL AD_DELETE_PROCS (K_H7)
        CALL AD_DELETE_PROCS (K_H6)
        CALL AD_DELETE_PROCS (K_H5)
        CALL AD_DELETE_PROCS (K_H4)
        CALL AD_DELETE_PROCS (K_H3)
        CALL AD_DELETE_PROCS (K_H2)
        CALL AD_DELETE_PROCS (K_H1)
        CALL AD_DELETE_PROCS (K_H0)
        
      END
      SUBROUTINE O_REMAP_AND_DBL (I_REMAP_AND_DBL, K_MREMAP_AND_DBL, I_A
     *, K_MA, I_N)
        IMPLICIT INTEGER (I-K), REAL (R-T), DOUBLE PRECISION (D-F), COMP
     *LEX (X-Z), CHARACTER (A-C), LOGICAL (L-N)
        
        INTEGER :: K_MREMAP_AND_DBL (0:24)
        INTEGER :: K_MA (0:24)
        
        INTEGER, DIMENSION (0:3, 0:ABS(I_N)/ABS(I_N)*((I_N+MAX(I_N*3,0)+
     *1)/2)-1) :: I_REMAP_AND_DBL
        INTEGER, INTENT (IN), DIMENSION (0:3, 0:ABS(I_N)/ABS(I_N)*((I_N+
     *MAX(I_N*(K_MA(6)-1),0)+1)/2)-1) :: I_A
        INTEGER :: I_N
        INTEGER, DIMENSION (0:1) :: K_PP
        INTEGER :: I_I
        INTEGER :: I_J
        
        LOGICAL  N_FIRSTCALL
        DATA     N_FIRSTCALL /.TRUE./
        INTEGER  ::  K_Q, K_H0, K_H1, K_H2, K_H3, K_H4, K_H5, K_H6, K_H7
     *, K_P0, K_P1 (0:0), K_P2 (0:1), K_P3 (0:2), K_P4 (0:3), K_P5 (0:4)
     *, K_P6 (0:5), K_P7 (0:6)
        COMMON /Q_PROCS/ K_Q, K_H0, K_H1, K_H2, K_H3, K_H4, K_H5, K_H6, 
     *K_H7, K_P0, K_P1, K_P2, K_P3, K_P4, K_P5, K_P6, K_P7
        
        INTEGER           ::  K_PTR, K_Z, K_TMP (0 : 299999)
        REAL              ::  T_TMP (0 : 299999)
        DOUBLE PRECISION  ::  F_TMP (0 : 149999)
        COMPLEX           ::  Z_TMP (0 : 149999)
        LOGICAL           ::  N_TMP (0 : 299999)
        EQUIVALENCE (K_TMP, T_TMP, F_TMP, Z_TMP, N_TMP)
        COMMON /Q_STACK/ K_PTR, K_Z, K_TMP
        
        CALL AD_INIT_PROCS (K_HP, 2, (/2, 2/))
        CALL AD_PROC_COORD (K_HP, K_PP)
        
        K_V0 = MAX(K_MA(5),0)
        K_V1 = MAX(K_MA(6),0)
        K_V2 = I_N
        K_V3 = I_N-1
        K_MREMAP_AND_DBL = (/66, 0, K_HP, 0, 0, 4, 4, 1, 1, 4, ABS(K_V2)
     */ABS(K_V2)*((K_V3+MAX(K_V2*3,0)+2)/2), K_V2, K_V3, 4, 4, 1, K_V2, 
     *8, 8, 4, 1, 2, 4, 0, 1/)
        
        IF (K_P0 == 0) THEN
          PRINT '(" remap_and_dbl:  initially...")'
        ENDIF
        K_T0 = K_PTR;   K_PTR = K_PTR + (K_V0*K_V1+1)/2*2
        IF (K_PTR .GT. 300000) CALL AD_STACK_ERR (300000)
        K_M0 = K_PTR;   K_PTR = K_PTR + 26
        IF (K_PTR .GT. 300000) CALL AD_STACK_ERR (300000)
        K_TMP (K_M0 : K_M0+24) = (/258, 0, K_H0, 0, 0, K_V0, K_V1, 1, 1,
     * K_V0, K_V1, 0, 0, K_V0, K_V1, 1, 1, K_V0, K_V1, K_V0, K_V1, 1, 1,
     * -1, -1/)
        
        CALL AD_REMAP_II (K_TMP(K_T0), K_TMP(K_M0), I_A, K_MA)
        
        IF (K_P0 == 0) THEN
          PRINT '(4i5)', K_TMP(K_T0:K_T0+(K_V0*K_V1-1))
        ENDIF
        K_PTR = K_PTR - ((K_V0*K_V1+1)/2*2+26)
        IF (K_P0 == 0) THEN
          PRINT *
        ENDIF
        DO K_C1 = 0, (K_V3+MAX(K_V2*3,0)+2)/2-1
          K_V4 = K_PP(0)*4
          K_V5 = MAX(K_V2-K_V4,0)
          K_V6 = K_C1*2+K_PP(1)
          IF (K_V2 > 0) THEN
            K_V7 = MAX((K_V2-K_V3+K_V6-1)/K_V2,0)
            K_V8 = MIN(K_V2*3+K_V3-K_V6,0)
          ELSE
            K_V7 = MAX((K_V2-K_V3+K_V6+1)/K_V2,0)
            K_V8 = MAX(K_V2*3+K_V3-K_V6,0)
          ENDIF
          K_V9 = K_C1*(ABS(K_V2)/ABS(K_V2))+(K_V3-K_V6+K_V2*K_V7)/ABS(K_
     *V2)
          K_V10 = K_V2/ABS(K_V2)
          K_V11 = MIN(K_V2-K_V4+3,3)
          K_V12 = K_C1*(ABS(K_V2)/ABS(K_V2))+K_V8/ABS(K_V2)
          DO K_1 = K_V9, K_V12, K_V10
            DO K_0 = K_V5, K_V11
              I_REMAP_AND_DBL (K_0,K_1) = 2*I_A (K_0,K_1)
            ENDDO
          ENDDO
        ENDDO
        
        IF (K_P0 == 0) THEN
          PRINT '(" remap_and_dbl:  after *2...")'
        ENDIF
        K_T0 = K_PTR;   K_PTR = K_PTR + 16
        IF (K_PTR .GT. 300000) CALL AD_STACK_ERR (300000)
        K_M0 = K_PTR;   K_PTR = K_PTR + 26
        IF (K_PTR .GT. 300000) CALL AD_STACK_ERR (300000)
        K_TMP (K_M0 : K_M0+24) = (/258, 0, K_H0, 0, 0, 4, 4, 1, 1, 4, 4,
     * 0, 0, 4, 4, 1, 1, 4, 4, 4, 4, 1, 1, -1, -1/)
        
        CALL AD_REMAP_II (K_TMP(K_T0), K_TMP(K_M0), I_REMAP_AND_DBL, K_M
     *REMAP_AND_DBL)
        
        IF (K_P0 == 0) THEN
          PRINT '(4i5)', K_TMP(K_T0:K_T0+(15))
        ENDIF
        K_PTR = K_PTR - 42
        IF (K_P0 == 0) THEN
          PRINT *
        ENDIF
        CALL AD_DELETE_PROCS (K_HP)
        
      END
