Sources Esope | Cast3M

arpale
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