Sources Esope | Cast3M

arpale
C ARPALE    SOURCE    MB234859  26/06/25    21:15:02     12580          
      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,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
 
        INSYM=SYME(4)
        CALL RESOU1 (IPKSIM,IDEMEN,NOID,NOEN,xspetl,0,1,INSYM,0)
        IF (IERR.NE.0) RETURN
 
      ELSEIF (bmat .EQ. 'I') THEN
 
        INSYM=SYME(1)
        CALL RESOU1 (IPRIGI,IDEMEN,NOID,NOEN,xspetl,0,1,INSYM,0)
        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