C ARPALE SOURCE PV 22/04/15 13:20:06 11344 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,0) 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,0) 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