C---------------------------------------------------------------
C Test of distributed scatter (AD_SCATTER) & distributed
C masked-scatter (AD_SCATTER_MASK).
C N.B. To make the test more thorough, this also includes the
C following complications:
C -- lower bounds != 1 in vector-subscripted array;
C -- vector subscripts are sections of arrays;
C -- type change across scatter assignment;
C -- wierd distributions of arrays and vector subscripts;
C---------------------------------------------------------------
C a & b distrib non-uniformly
C 'v' has crazy alignment
C     and distribution
C------------------------------!
C Initialise vector subscripts !
C------------------------------!
C "v1" = v (1:5)  = (/6,9,8,2,5/) + 10       -- vec subscript for dim 1
C "v2" = v (6:12) = (/5,6,4,7,3,8,2/)) - 10  -- vec subscript for dim 2
      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_MV (0:15)
        INTEGER :: K_MB (0:24)
        INTEGER :: K_MA (0:24)
        
        INTEGER, DIMENSION (0:6) :: I_V
        INTEGER, DIMENSION (0:1, 0:3) :: I_B
        REAL, DIMENSION (0:2, 0:4) :: R_A
        INTEGER, DIMENSION (0:1) :: K_PP
        
        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, (/3, 2/))
        CALL AD_PROC_COORD (K_HP, K_PP)
        
        K_MV = (/73, 0, K_HP, 0, 12, 1, 7, 25, 12, -2, 31, 2, 4, 1, 0, 0
     */)
        K_MB = (/66, 0, K_HP, 0, 0, 5, 7, 1, 1, 2, 4, 0, 0, 5, 7, 1, 1, 
     *5, 7, 2, 4, 2, 2, 0, 1/)
        K_MA = (/66, 0, K_HP, 0, 0, 9, 9, 1, 1, 3, 5, 0, 0, 9, 9, 1, 1, 
     *9, 9, 3, 5, 2, 2, 0, 1/)
        
        IF (K_PP(0) == 0 .AND. K_PP(1) == 0) THEN
          I_V (6) = 16
        ENDIF
        
        IF (K_PP(0) == 0 .AND. K_PP(1) == 1) THEN
          I_V (5) = 19
        ENDIF
        
        IF (K_PP(0) == 0 .AND. K_PP(1) == 0) THEN
          I_V (5) = 18
        ENDIF
        
        IF (K_PP(0) == 0 .AND. K_PP(1) == 1) THEN
          I_V (4) = 12
        ENDIF
        
        IF (K_PP(0) == 0 .AND. K_PP(1) == 0) THEN
          I_V (4) = 15
        ENDIF
        
        IF (K_PP(0) == 0 .AND. K_PP(1) == 1) THEN
          I_V (3) = -5
        ENDIF
        
        IF (K_PP(0) == 0 .AND. K_PP(1) == 0) THEN
          I_V (3) = -4
        ENDIF
        
        IF (K_PP(0) == 0 .AND. K_PP(1) == 1) THEN
          I_V (2) = -6
        ENDIF
        
        IF (K_PP(0) == 0 .AND. K_PP(1) == 0) THEN
          I_V (2) = -3
        ENDIF
        
        IF (K_PP(0) == 0 .AND. K_PP(1) == 1) THEN
          I_V (1) = -7
        ENDIF
        
        IF (K_PP(0) == 0 .AND. K_PP(1) == 0) THEN
          I_V (1) = -2
        ENDIF
        
        IF (K_PP(0) == 0 .AND. K_PP(1) == 1) THEN
          I_V (0) = -8
        ENDIF
        
C---------------------!
C Unmasked scatter... !
C---------------------!
        DO 10 I_I = 1, 9
          DO 20 I_J = 1, 9
C i.e. a (i,j) = "ij"
            IF (K_PP(0) == (I_I-1)/3 .AND. K_PP(1) == (I_J-1)/5) THEN
              K_V0 = MOD(I_I-1,3)
              K_V1 = MOD(I_J-1,5)
              R_A (K_V0,K_V1) = I_I*10+I_J
            ENDIF
            
   20     CONTINUE
   10   CONTINUE
C i.e. b (i,j) = "-ij"
        K_T0 = K_PTR;   K_PTR = K_PTR + 8
        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+8) = (/66, 0, K_HP, 0, 0, 5, 7, 1, 1/)
        K_TMP (K_M0+9 : K_M0+24) = K_MA (9 : 24)
        
        CALL AD_REMAP_RR (T_TMP(K_T0), K_MB, R_A, K_TMP(K_M0))
        K_PTR = K_PTR - 26
        
        K_V0 = MIN(-K_PP(0)*2+4,1)
        K_V1 = MIN(-K_PP(1)*4+6,3)
        K_T0_1 = K_T0
        DO K_1 = 0, K_V1
          K_T0_0 = K_T0_1
          DO K_0 = 0, K_V0
            I_B (K_0,K_1) = -T_TMP (K_T0_0)
            K_T0_0 = K_T0_0 + (1)
          ENDDO
          K_T0_1 = K_T0_1 + (2)
        ENDDO
        
        K_PTR = K_PTR - 8
        K_T0 = K_PTR;   K_PTR = K_PTR + 2
        IF (K_PTR .GT. 300000) CALL AD_STACK_ERR (300000)
        K_T1 = K_PTR;   K_PTR = K_PTR + 2
        IF (K_PTR .GT. 300000) CALL AD_STACK_ERR (300000)
        K_M0 = K_PTR;   K_PTR = K_PTR + 14
        IF (K_PTR .GT. 300000) CALL AD_STACK_ERR (300000)
        K_TMP (K_M0 : K_M0+13) = (/65, 0, K_HP, 0, 5, 1, 2, 0, 5, 1, 5, 
     *2, 2, 0/)
        
        K_M1 = K_PTR;   K_PTR = K_PTR + 16
        IF (K_PTR .GT. 300000) CALL AD_STACK_ERR (300000)
        K_TMP (K_M1 : K_M1+5) = (/73, 0, K_HP, 0, 5, 1/)
        K_TMP (K_M1+6 : K_M1+15) = K_MV (6 : 15)
        
        CALL AD_REMAP_II (K_TMP(K_T1), K_TMP(K_M0), I_V, K_TMP(K_M1))
        K_PTR = K_PTR - 16
        
        K_V0 = MIN(-K_PP(0)*2+4,1)
        K_T1_0 = K_T1
        K_T0_0 = K_T0
        DO K_0 = 0, K_V0
          K_TMP (K_T0_0) = K_TMP (K_T1_0)-11
          K_T1_0 = K_T1_0 + (1)
          K_T0_0 = K_T0_0 + (1)
        ENDDO
        
        K_T2 = K_PTR;   K_PTR = K_PTR + 4
        IF (K_PTR .GT. 300000) CALL AD_STACK_ERR (300000)
        K_T3 = K_PTR;   K_PTR = K_PTR + 4
        IF (K_PTR .GT. 300000) CALL AD_STACK_ERR (300000)
        K_M1 = K_PTR;   K_PTR = K_PTR + 14
        IF (K_PTR .GT. 300000) CALL AD_STACK_ERR (300000)
        K_TMP (K_M1 : K_M1+13) = (/65, 0, K_HP, 0, 7, 1, 4, 0, 7, 1, 7, 
     *4, 2, 1/)
        
        K_M2 = K_PTR;   K_PTR = K_PTR + 16
        IF (K_PTR .GT. 300000) CALL AD_STACK_ERR (300000)
        K_TMP (K_M2 : K_M2+5) = (/73, 0, K_HP, 5, 7, 1/)
        K_TMP (K_M2+6 : K_M2+15) = K_MV (6 : 15)
        
        CALL AD_REMAP_II (K_TMP(K_T3), K_TMP(K_M1), I_V, K_TMP(K_M2))
        K_PTR = K_PTR - 16
        
        K_V0 = MIN(-K_PP(1)*4+6,3)
        K_T3_0 = K_T3
        K_T2_0 = K_T2
        DO K_0 = 0, K_V0
          K_TMP (K_T2_0) = K_TMP (K_T3_0)+9
          K_T3_0 = K_T3_0 + (1)
          K_T2_0 = K_T2_0 + (1)
        ENDDO
        
        K_T4 = K_PTR;   K_PTR = K_PTR + 8
        IF (K_PTR .GT. 300000) CALL AD_STACK_ERR (300000)
        K_V0 = MIN(-K_PP(0)*2+4,1)
        K_V1 = MIN(-K_PP(1)*4+6,3)
        K_T4_1 = K_T4
        DO K_1 = 0, K_V1
          K_T4_0 = K_T4_1
          DO K_0 = 0, K_V0
            T_TMP (K_T4_0) = I_B (K_0,K_1)
            K_T4_0 = K_T4_0 + (1)
          ENDDO
          K_T4_1 = K_T4_1 + (2)
        ENDDO
        
        K_M2 = K_PTR;   K_PTR = K_PTR + 26
        IF (K_PTR .GT. 300000) CALL AD_STACK_ERR (300000)
        K_TMP (K_M2 : K_M2+8) = (/66, 0, K_HP, 0, 0, -2, -2, 1, 1/)
        K_TMP (K_M2+9 : K_M2+24) = K_MA (9 : 24)
        
        CALL AD_SCATTER_RR (T_TMP(K_T4), K_MB, R_A, K_TMP(K_M2), K_TMP(K
     *_T0), K_TMP(K_M0), K_TMP(K_T2), K_TMP(K_M1))
        K_PTR = K_PTR - 34
        K_PTR = K_PTR - 40
        
        IF (K_P0 == 0) THEN
          PRINT "(' Unmasked scatter;  a = ')"
        ENDIF
        DO 30 I_I = 1, 9
          K_T0 = K_PTR;   K_PTR = K_PTR + 10
          IF (K_PTR .GT. 300000) CALL AD_STACK_ERR (300000)
          K_M0 = K_PTR;   K_PTR = K_PTR + 14
          IF (K_PTR .GT. 300000) CALL AD_STACK_ERR (300000)
          K_TMP (K_M0 : K_M0+13) = (/257, 0, K_H0, 0, 9, 1, 9, 0, 9, 1, 
     *9, 9, 1, -1/)
          
          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+8) = (/66, 0, K_HP, I_I-1, 0, -1, 9, 1, 1/)
          K_TMP (K_M1+9 : K_M1+24) = K_MA (9 : 24)
          
          CALL AD_REMAP_RR (T_TMP(K_T0), K_TMP(K_M0), R_A, K_TMP(K_M1))
          K_PTR = K_PTR - 26
          
          IF (K_P0 == 0) THEN
            PRINT '(9(f4.0, 2x))', T_TMP(K_T0:K_T0+(8))
          ENDIF
          K_PTR = K_PTR - 24
   30   CONTINUE
        IF (K_P0 == 0) THEN
          PRINT *
        ENDIF
C---------------------!
C Masked scatter...   !
C---------------------!
        DO 40 I_I = 1, 9
          DO 50 I_J = 1, 9
C i.e. a (i,j) = "ij"
            IF (K_PP(0) == (I_I-1)/3 .AND. K_PP(1) == (I_J-1)/5) THEN
              K_V0 = MOD(I_I-1,3)
              K_V1 = MOD(I_J-1,5)
              R_A (K_V0,K_V1) = I_I*10+I_J
            ENDIF
            
   50     CONTINUE
   40   CONTINUE
C i.e. b (i,j) = "-ij"
        K_T0 = K_PTR;   K_PTR = K_PTR + 8
        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+8) = (/66, 0, K_HP, 0, 0, 5, 7, 1, 1/)
        K_TMP (K_M0+9 : K_M0+24) = K_MA (9 : 24)
        
        CALL AD_REMAP_RR (T_TMP(K_T0), K_MB, R_A, K_TMP(K_M0))
        K_PTR = K_PTR - 26
        
        K_V0 = MIN(-K_PP(0)*2+4,1)
        K_V1 = MIN(-K_PP(1)*4+6,3)
        K_T0_1 = K_T0
        DO K_1 = 0, K_V1
          K_T0_0 = K_T0_1
          DO K_0 = 0, K_V0
            I_B (K_0,K_1) = -T_TMP (K_T0_0)
            K_T0_0 = K_T0_0 + (1)
          ENDDO
          K_T0_1 = K_T0_1 + (2)
        ENDDO
        
        K_PTR = K_PTR - 8
        K_T0 = K_PTR;   K_PTR = K_PTR + 8
        IF (K_PTR .GT. 300000) CALL AD_STACK_ERR (300000)
        K_V0 = MIN(-K_PP(0)*2+4,1)
        K_V1 = MIN(-K_PP(1)*4+6,3)
        K_T0_1 = K_T0
        DO K_1 = 0, K_V1
          K_T0_0 = K_T0_1
          DO K_0 = 0, K_V0
            N_TMP (K_T0_0) = MOD(I_B (K_0,K_1)+I_B (K_0,K_1)/10,2).EQ.0
            K_T0_0 = K_T0_0 + (1)
          ENDDO
          K_T0_1 = K_T0_1 + (2)
        ENDDO
        
        K_T1 = K_PTR;   K_PTR = K_PTR + 2
        IF (K_PTR .GT. 300000) CALL AD_STACK_ERR (300000)
        K_T2 = K_PTR;   K_PTR = K_PTR + 2
        IF (K_PTR .GT. 300000) CALL AD_STACK_ERR (300000)
        K_M0 = K_PTR;   K_PTR = K_PTR + 14
        IF (K_PTR .GT. 300000) CALL AD_STACK_ERR (300000)
        K_TMP (K_M0 : K_M0+13) = (/65, 0, K_HP, 0, 5, 1, 2, 0, 5, 1, 5, 
     *2, 2, 0/)
        
        K_M1 = K_PTR;   K_PTR = K_PTR + 16
        IF (K_PTR .GT. 300000) CALL AD_STACK_ERR (300000)
        K_TMP (K_M1 : K_M1+5) = (/73, 0, K_HP, 0, 5, 1/)
        K_TMP (K_M1+6 : K_M1+15) = K_MV (6 : 15)
        
        CALL AD_REMAP_II (K_TMP(K_T2), K_TMP(K_M0), I_V, K_TMP(K_M1))
        K_PTR = K_PTR - 16
        
        K_V0 = MIN(-K_PP(0)*2+4,1)
        K_T2_0 = K_T2
        K_T1_0 = K_T1
        DO K_0 = 0, K_V0
          K_TMP (K_T1_0) = K_TMP (K_T2_0)-11
          K_T2_0 = K_T2_0 + (1)
          K_T1_0 = K_T1_0 + (1)
        ENDDO
        
        K_T3 = K_PTR;   K_PTR = K_PTR + 4
        IF (K_PTR .GT. 300000) CALL AD_STACK_ERR (300000)
        K_T4 = K_PTR;   K_PTR = K_PTR + 4
        IF (K_PTR .GT. 300000) CALL AD_STACK_ERR (300000)
        K_M1 = K_PTR;   K_PTR = K_PTR + 14
        IF (K_PTR .GT. 300000) CALL AD_STACK_ERR (300000)
        K_TMP (K_M1 : K_M1+13) = (/65, 0, K_HP, 0, 7, 1, 4, 0, 7, 1, 7, 
     *4, 2, 1/)
        
        K_M2 = K_PTR;   K_PTR = K_PTR + 16
        IF (K_PTR .GT. 300000) CALL AD_STACK_ERR (300000)
        K_TMP (K_M2 : K_M2+5) = (/73, 0, K_HP, 5, 7, 1/)
        K_TMP (K_M2+6 : K_M2+15) = K_MV (6 : 15)
        
        CALL AD_REMAP_II (K_TMP(K_T4), K_TMP(K_M1), I_V, K_TMP(K_M2))
        K_PTR = K_PTR - 16
        
        K_V0 = MIN(-K_PP(1)*4+6,3)
        K_T4_0 = K_T4
        K_T3_0 = K_T3
        DO K_0 = 0, K_V0
          K_TMP (K_T3_0) = K_TMP (K_T4_0)+9
          K_T4_0 = K_T4_0 + (1)
          K_T3_0 = K_T3_0 + (1)
        ENDDO
        
        K_T5 = K_PTR;   K_PTR = K_PTR + 8
        IF (K_PTR .GT. 300000) CALL AD_STACK_ERR (300000)
        K_V0 = MIN(-K_PP(0)*2+4,1)
        K_V1 = MIN(-K_PP(1)*4+6,3)
        K_T5_1 = K_T5
        DO K_1 = 0, K_V1
          K_T5_0 = K_T5_1
          DO K_0 = 0, K_V0
            T_TMP (K_T5_0) = I_B (K_0,K_1)
            K_T5_0 = K_T5_0 + (1)
          ENDDO
          K_T5_1 = K_T5_1 + (2)
        ENDDO
        
        K_M2 = K_PTR;   K_PTR = K_PTR + 26
        IF (K_PTR .GT. 300000) CALL AD_STACK_ERR (300000)
        K_TMP (K_M2 : K_M2+8) = (/66, 0, K_HP, 0, 0, -2, -2, 1, 1/)
        K_TMP (K_M2+9 : K_M2+24) = K_MA (9 : 24)
        
        CALL AD_SCATTER_MASK_RR (T_TMP(K_T5), K_MB, R_A, K_TMP(K_M2), N_
     *TMP(K_T0), K_MB, K_TMP(K_T1), K_TMP(K_M0), K_TMP(K_T3), K_TMP(K_M1
     *))
        K_PTR = K_PTR - 34
        K_PTR = K_PTR - 40
        
        K_PTR = K_PTR - 8
        IF (K_P0 == 0) THEN
          PRINT "(' Masked scatter;  a = ')"
        ENDIF
        DO 60 I_I = 1, 9
          K_T0 = K_PTR;   K_PTR = K_PTR + 10
          IF (K_PTR .GT. 300000) CALL AD_STACK_ERR (300000)
          K_M0 = K_PTR;   K_PTR = K_PTR + 14
          IF (K_PTR .GT. 300000) CALL AD_STACK_ERR (300000)
          K_TMP (K_M0 : K_M0+13) = (/257, 0, K_H0, 0, 9, 1, 9, 0, 9, 1, 
     *9, 9, 1, -1/)
          
          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+8) = (/66, 0, K_HP, I_I-1, 0, -1, 9, 1, 1/)
          K_TMP (K_M1+9 : K_M1+24) = K_MA (9 : 24)
          
          CALL AD_REMAP_RR (T_TMP(K_T0), K_TMP(K_M0), R_A, K_TMP(K_M1))
          K_PTR = K_PTR - 26
          
          IF (K_P0 == 0) THEN
            PRINT '(9(f4.0, 2x))', T_TMP(K_T0:K_T0+(8))
          ENDIF
          K_PTR = K_PTR - 24
   60   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
C---------------------------------------------------------------
C Expected output
C ~~~~~~~~~~~~~~~
C dim 1:
C ------
C Rows of 'a' originally have 1st digit ==
C 1 2 3 4 5 6 7 8 9
C 0verwrite them with these rows of 'b':
C . 4 . . 5 1 . 3 2         (since v1 = (/6,9,8,2,5/)+10)
C dim 2:
C ------
C Coulumns of 'a' originally have 2nd digit ==
C 1 2 3 4 5 6 7 8 9
C 0verwrite them with these cols of 'b':
C . 7 5 3 1 2 4 6 .         (since v2 = (/5,6,4,7,3,8,2/)-10)
C Hence, 'a' should be...
C Unmasked:
C ~~~~~~~~~
C  11   12   13   14   15   16   17   18   19
C  21  -47  -45  -43  -41  -42  -44  -46   29
C  31   32   33   34   35   36   37   38   39
C  41   42   43   44   45   46   47   48   49
C  51  -57  -55  -53  -51  -52  -54  -56   59
C  61  -17  -15  -13  -11  -12  -14  -16   69
C  71   72   73   74   75   76   77   78   79
C  81  -37  -35  -33  -31  -32  -34  -36   89
C  91  -27  -25  -23  -21  -22  -24  -26   99
C Masked:
C ~~~~~~~
C Taking mask into account ((MOD (b+b/10,2)==0), i.e. selecting
C elements b (i,j) s.t. (i+j) is even),  'a' is as above but only
C with -ve elements "-ij" s.t. (i+j) is even! ...
C  11   12   13   14   15   16   17   18   19
C  21   22   23   24   25  -42  -44  -46   29
C  31   32   33   34   35   36   37   38   39
C  41   42   43   44   45   46   47   48   49
C  51  -57  -55  -53  -51   56   57   58   59
C  61  -17  -15  -13  -11   66   67   68   69
C  71   72   73   74   75   76   77   78   79
C  81  -37  -35  -33  -31   86   87   88   89
C  91   92   93   94   95  -22  -24  -26   99
C---------------------------------------------------------------
