*DECK FLDDEF
      SUBROUTINE FLDDEF (MAX,IPTRK,IPSYS,LL4,ITY,NGRP,IMOD,LMOD,EVECT,
     1 ADECT,VEC,IADJ,VEA,VEB)
*
*-----------------------------------------------------------------------
*
*Purpose:
* multigroup Hotelling deflation procedure (1- multiplication of the
* 'A' matrix by a vector; 2- multiplication of a deflated 'B' matrix
* by the same vector).
*
*Copyright:
* Copyright (C) 2002 Ecole Polytechnique de Montreal
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
* License as published by the Free Software Foundation; either
* version 2.1 of the License, or (at your option) any later version
*
*Author(s): A. Hebert
*
*Parameters: input
* MAX     first dimension of arrays EVECT, ADECT, VEC, VEA and VEB.
* IPTRK   L_TRACK pointer to the tracking information.
* IPSYS   L_SYSTEM pointer to system matrices.
* LL4     order of the system matrices.
* ITY     type of solution (2: classical Trivac; 3: Thomas-Raviart).
* NGRP    number of energy groups.
* IMOD    number of the harmonic to be deflated.
* LMOD    total number of harmonics.
* EVECT   direct eigenvector.
* ADECT   adjoint eigenvector.
* VEC     vector to be multiplied.
* IADJ    type of deflation:
*         =1 for a direct deflation; =2 for an adjoint deflation.
*
*Parameters: output
* VEA     result of the multiplication to the 'A' matrix.
* VEB     result of the multiplication to the 'B' matrix.
*
*-----------------------------------------------------------------------
*
      USE GANLIB
*----
*  SUBROUTINE ARGUMENTS
*----
      TYPE(C_PTR) IPTRK,IPSYS
      INTEGER MAX,LL4,ITY,NGRP,IMOD,LMOD,IADJ
      REAL EVECT(MAX,NGRP,LMOD),ADECT(MAX,NGRP,LMOD),VEC(MAX,NGRP),
     1 VEA(MAX,NGRP),VEB(MAX,NGRP)
*----
*  LOCAL VARIABLES
*----
      CHARACTER*12 TEXT12
      DOUBLE PRECISION DDELN1,DDELD1
      REAL, DIMENSION(:), ALLOCATABLE :: GAF,W
      REAL, DIMENSION(:), POINTER :: AGARM
      TYPE(C_PTR) AGARM_PTR
*----
*  SCRATCH STORAGE ALLOCATION
*----
      ALLOCATE(GAF(LL4))
*
      IF(IADJ.EQ.1) THEN
*        DIRECT CASE.
         DO 40 IGR=1,NGRP
         CALL XDRSET(VEB(1,IGR),LL4,0.0)
         DO 40 JGR=1,NGRP
         WRITE(TEXT12,'(1HB,2I3.3)') IGR,JGR
         CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM)
         IF(ILONG.EQ.0) GO TO 40
         CALL LCMGPD(IPSYS,TEXT12,AGARM_PTR)
         CALL C_F_POINTER(AGARM_PTR,AGARM,(/ ILONG /))
         DO 20 I=1,ILONG
   20    VEB(I,IGR)=VEB(I,IGR)+AGARM(I)*VEC(I,JGR)
   40    CONTINUE
         DO 130 JMOD=1,IMOD-1
         DDELN1=0.0D0
         DDELD1=0.0D0
         DO 120 IGR=1,NGRP
         WRITE(TEXT12,'(1HA,2I3.3)') IGR,IGR
         CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,EVECT(1,IGR,JMOD),
     1   VEA(1,IGR))
         CALL XDRSET(GAF,LL4,0.0)
         DO 110 JGR=1,NGRP
         IF(JGR.EQ.IGR) GO TO 80
         WRITE(TEXT12,'(1HA,2I3.3)') IGR,JGR
         CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM)
         IF(ILONG.EQ.0) GO TO 80
         IF(ITY.EQ.13) THEN
            ALLOCATE(W(LL4))
            CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,EVECT(1,JGR,JMOD),W)
            DO 50 I=1,LL4
   50       VEA(I,IGR)=VEA(I,IGR)-W(I)
            DEALLOCATE(W)
         ELSE
            CALL LCMGPD(IPSYS,TEXT12,AGARM_PTR)
            CALL C_F_POINTER(AGARM_PTR,AGARM,(/ ILONG /))
            DO 60 I=1,ILONG
   60       VEA(I,IGR)=VEA(I,IGR)-AGARM(I)*EVECT(I,JGR,JMOD)
         ENDIF
   80    WRITE(TEXT12,'(1HB,2I3.3)') JGR,IGR
         CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM)
         IF(ILONG.EQ.0) GO TO 110
         CALL LCMGPD(IPSYS,TEXT12,AGARM_PTR)
         CALL C_F_POINTER(AGARM_PTR,AGARM,(/ ILONG /))
         DO 90 I=1,ILONG
   90    GAF(I)=GAF(I)+AGARM(I)*ADECT(I,JGR,JMOD)
  110    CONTINUE
         DO 120 I=1,LL4
         DDELN1=DDELN1+GAF(I)*VEC(I,IGR)
  120    DDELD1=DDELD1+ADECT(I,IGR,JMOD)*VEA(I,IGR)
         DDELN1=DDELN1/DDELD1
         DO 130 IGR=1,NGRP
         DO 130 I=1,LL4
  130    VEB(I,IGR)=VEB(I,IGR)-VEA(I,IGR)*REAL(DDELN1)
         DO 160 IGR=1,NGRP
         WRITE(TEXT12,'(1HA,2I3.3)') IGR,IGR
         CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,VEC(1,IGR),VEA(1,IGR))
         DO 160 JGR=1,NGRP
         IF(JGR.EQ.IGR) GO TO 160
         WRITE(TEXT12,'(1HA,2I3.3)') IGR,JGR
         CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM)
         IF(ILONG.EQ.0) GO TO 160
         IF(ITY.EQ.13) THEN
            ALLOCATE(W(LL4))
            CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,VEC(1,JGR),W)
            DO 135 I=1,LL4
  135       VEA(I,IGR)=VEA(I,IGR)-W(I)
            DEALLOCATE(W)
         ELSE
            CALL LCMGPD(IPSYS,TEXT12,AGARM_PTR)
            CALL C_F_POINTER(AGARM_PTR,AGARM,(/ ILONG /))
            DO 140 I=1,ILONG
  140       VEA(I,IGR)=VEA(I,IGR)-AGARM(I)*VEC(I,JGR)
         ENDIF
  160    CONTINUE
      ELSE IF(IADJ.EQ.2) THEN
*        ADJOINT CASE.
         DO 200 IGR=1,NGRP
         CALL XDRSET(VEB(1,IGR),LL4,0.0)
         DO 200 JGR=1,NGRP
         WRITE(TEXT12,'(1HB,2I3.3)') JGR,IGR
         CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM)
         IF(ILONG.EQ.0) GO TO 200
         CALL LCMGPD(IPSYS,TEXT12,AGARM_PTR)
         CALL C_F_POINTER(AGARM_PTR,AGARM,(/ ILONG /))
         DO 180 I=1,ILONG
  180    VEB(I,IGR)=VEB(I,IGR)+AGARM(I)*VEC(I,JGR)
  200    CONTINUE
         DO 290 JMOD=1,IMOD-1
         DDELN1=0.0D0
         DDELD1=0.0D0
         DO 280 IGR=1,NGRP
         WRITE(TEXT12,'(1HA,2I3.3)') IGR,IGR
         CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,ADECT(1,IGR,JMOD),
     1   VEA(1,IGR))
         CALL XDRSET(GAF,LL4,0.0)
         DO 270 JGR=1,NGRP
         IF(JGR.EQ.IGR) GO TO 240
         WRITE(TEXT12,'(1HA,2I3.3)') JGR,IGR
         CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM)
         IF(ILONG.EQ.0) GO TO 240
         IF(ITY.EQ.13) THEN
            ALLOCATE(W(LL4))
            CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,ADECT(1,JGR,JMOD),W)
            DO 210 I=1,LL4
  210       VEA(I,IGR)=VEA(I,IGR)-W(I)
            DEALLOCATE(W)
         ELSE
            CALL LCMGPD(IPSYS,TEXT12,AGARM_PTR)
            CALL C_F_POINTER(AGARM_PTR,AGARM,(/ ILONG /))
            DO 220 I=1,ILONG
  220       VEA(I,IGR)=VEA(I,IGR)-AGARM(I)*ADECT(I,JGR,JMOD)
         ENDIF
  240    WRITE(TEXT12,'(1HB,2I3.3)') IGR,JGR
         CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM)
         IF(ILONG.EQ.0) GO TO 270
         CALL LCMGPD(IPSYS,TEXT12,AGARM_PTR)
         CALL C_F_POINTER(AGARM_PTR,AGARM,(/ ILONG /))
         DO 250 I=1,ILONG
  250    GAF(I)=GAF(I)+AGARM(I)*EVECT(I,JGR,JMOD)
  270    CONTINUE
         DO 280 I=1,LL4
         DDELN1=DDELN1+GAF(I)*VEC(I,IGR)
  280    DDELD1=DDELD1+EVECT(I,IGR,JMOD)*VEA(I,IGR)
         DDELN1=DDELN1/DDELD1
         DO 290 IGR=1,NGRP
         DO 290 I=1,LL4
  290    VEB(I,IGR)=VEB(I,IGR)-VEA(I,IGR)*REAL(DDELN1)
         DO 320 IGR=1,NGRP
         WRITE(TEXT12,'(1HA,2I3.3)') IGR,IGR
         CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,VEC(1,IGR),VEA(1,IGR))
         DO 320 JGR=1,NGRP
         IF(JGR.EQ.IGR) GO TO 320
         WRITE(TEXT12,'(1HA,2I3.3)') JGR,IGR
         CALL LCMLEN(IPSYS,TEXT12,ILONG,ITYLCM)
         IF(ILONG.EQ.0) GO TO 320
         IF(ITY.EQ.13) THEN
            ALLOCATE(W(LL4))
            CALL MTLDLM(TEXT12,IPTRK,IPSYS,LL4,ITY,VEC(1,JGR),W)
            DO 295 I=1,LL4
  295       VEA(I,IGR)=VEA(I,IGR)-W(I)
            DEALLOCATE(W)
         ELSE
            CALL LCMGPD(IPSYS,TEXT12,AGARM_PTR)
            CALL C_F_POINTER(AGARM_PTR,AGARM,(/ ILONG /))
            DO 300 I=1,ILONG
  300       VEA(I,IGR)=VEA(I,IGR)-AGARM(I)*VEC(I,JGR)
         ENDIF
  320    CONTINUE
      ENDIF
*----
*  SCRATCH STORAGE DEALLOCATION
*----
      DEALLOCATE(GAF)
      RETURN
      END
