C ARPALE    SOURCE    PV090527  24/06/09    21:15:02     11936          
      SUBROUTINE ARPALE (IPRTRA,IPMAUP,QUAD)



***********************************************************************
*
*                          A R P A L E
*
* FONCTION:
* ---------
*
*     INITIALISATION DU VECTEUR RESIDUEL D'ARPACK
*     (Cinematiquement Admissible a 0)
*
*
* PARAMETRES:  (E)=ENTREE   (S)=SORTIE
* -----------
*
*
*     IPRTRA   ENTIER    (E)  POINTEUR DES OPERATEURS DE TRAVAIL
*
*     IPMAUP   ENTIER    (E/S)  POINTEUR DES ELEMENTS ARPACK
*
*
* SOUS-PROGRAMMES APPELES:
* ------------------------
*
*     TDRAND,ARCORC,MUCPRI,RESOU1,LDMT,CHV3,ALEAT1
*
* AUTEUR, DATE DE CREATION:
* -------------------------
*
*     PASCAL BOUDA     29 JUIN 2015
*
* LANGAGE:
* --------
*
*     FORTRAN 77 & 90
*
************************************************************************

      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)


-INC PPARAM
-INC CCOPTIO
-INC SMCHPOI
-INC SMRIGID
-INC SMVECTD
-INC TARWORK
-INC CCREEL

      SEGMENT idemen(0)

      INTEGER IPRTRA
      INTEGER IPMAUP
      LOGICAL QUAD

      INTEGER IPRIGI, IPMASS, IPKSIM
      REAL*8 VA
      INTEGER IPCHO
      INTEGER IPCHP1,IPCHP2
      INTEGER NOID,NOEN

      xspetl = xspeti
      SEGINI IDEMEN
      IDEMEN(**)=0
      NOID=0
      NOEN=1


      MAUP=IPMAUP
      SEGACT MAUP*MOD


************************************************************************
*                            CAS QUADRATIQUE
************************************************************************

*pas de conditions particulières pour le vecteur initial
*(pour l'instant ?)

      IF (QUAD) THEN

        DO i=1,resid(/1)
          CALL TDRAND(VA)
          resid(i)=VA
        ENDDO

        GOTO 999

      ENDIF


************************************************************************
*                              CAS LINEAIRE
************************************************************************

      MRITRA=IPRTRA
      SEGACT MRITRA

      MRIGID=RIGI(1)
      SEGACT MRIGID
      IPCHO=ICHOLE
      SEGDES MRIGID

****************************************
*Creation d'un vecteur aleatoire primal*
****************************************
      IPRIGI=RIGI(1)
      IPMASS=RIGI(2)
      IPKSIM=RIGI(4)
      CALL ALEAT1(IPRIGI,IPCHP1)

************************************************************
*Calcul du nombre d'inconnues vraies (ddl's sans relations)*
************************************************************

      NDDL = 0
      NDLX = 0

      MCHPOI = IPCHP1



      SEGACT MCHPOI
      NSOUS = IPCHP(/1)

      DO ISOUS = 1, NSOUS
        MSOUPO = IPCHP(ISOUS)
        SEGACT MSOUPO
        MPOVAL = IPOVAL
        SEGACT MPOVAL
        NN = VPOCHA(/1)
        NC1 = VPOCHA(/2)
        NDDL = NDDL + NN*NC1
        DO INC = 1,NC1
          IF (NOCOMP(INC) .EQ. 'LX ') NDLX = NDLX + NN
        ENDDO
        SEGDES MSOUPO, MPOVAL
      ENDDO

      SEGDES MCHPOI

      NDDL = NDDL - NDLX - (NDLX/2)

      IF (IIMPI.GE.1) THEN
        WRITE(IOIMP,*) NDDL, 'INCONNUES SONT SANS RELATIONS'
      ENDIF

*Ajustement de la taille des segments si necessaire (modification du
*de la dimension de la base d'Arnoldi

      IF (v(/2) .GT. NDDL) THEN

        ndim=resid(/1)
        ncv=NDDL
        lipntr=ipntr(/1)
        lworkl=workl(/1)
        lnev=dr(/1)

        SEGADJ MAUP

      ENDIF

*****************************
*Creation du residu initial *
*****************************

      MAUP=IPMAUP
      SEGACT MAUP*MOD

*en fonction du type de probleme, on realise une iteration d'Arnoldi;
*voir documentation de ARPITL.ESO et ARPTIQ.ESO pour plus de details


      IF (iparam(7) .EQ. 3) THEN

        CALL MUCPRI (IPCHP1,IPMASS,IPCHP2)
*Mise a zero des inconnues en FPI : certainement inutile ?
        CALL ARCORC (IPCHP2,15)

      ELSEIF (iparam(7) .EQ. 4) THEN

        CALL MUCPRI (IPCHP1,IPRIGI,IPCHP2)
*Mise a sero des inconnues en FLX
        CALL ARCORC (IPCHP2,10)
*Mise a zero des inconnues en FPI : certainement inutile ?
        CALL ARCORC (IPCHP2,15)

      ENDIF

      IDEMEN(1)=IPCHP2


      IF (bmat .EQ. 'G') THEN

        IF (SYME(4) .EQ. 0) THEN
          CALL RESOU1 (IPKSIM,IDEMEN,NOID,NOEN,xspetl,0,1)
        ELSEIF (SYME(4) .EQ. 1) THEN
          CALL LDMT   (IPKSIM,IDEMEN,NOID,NOEN,xspetl,0)
        ENDIF
        IF (IERR.NE.0) RETURN

      ELSEIF (bmat .EQ. 'I') THEN

        IF (SYME(1) .EQ. 0) THEN
          CALL RESOU1 (IPRIGI,IDEMEN,NOID,NOEN,xspetl,0,1)
        ELSEIF (SYME(1) .EQ. 1) THEN
          CALL LDMT   (IPRIGI,IDEMEN,NOID,NOEN,xspetl,0)
        ENDIF
        IF (IERR.NE.0) RETURN
      ENDIF
C     RESOU desactive IDEMEN on le reactive
      SEGACT,IDEMEN


      IPCHP1=IDEMEN(1)



*transformation en vecteur primal
      CALL CHV3 (IPCHO,IPCHP1,IPVEC,1)

      MVECTD=IPVEC
      SEGACT MVECTD
*Stockage du vecteur residu
      DO i=1,resid(/1)
        resid(i)=VECTBB(i)
      ENDDO

      SEGSUP MVECTD


      SEGDES MRITRA


999   CONTINUE



      IPMAUP=MAUP
c       SEGDES MAUP


      END