C PROCH2 SOURCE CB215821 25/04/22 21:15:13 12245 SUBROUTINE PROCH2 (FREQ,IPRIGI,IPMASS,INF0,IPMODE,IALEAT, & LIMAGE, INSYM, MTAB3,I) ************************************************************************ * * P R O C H 2 * ----------- * * FONCTION: * --------- * * RECHERCHE D'UN MODE PROPRE. * * MODE D'APPEL: * ------------- * * CALL PROCH2 (FREQ,IPRIGI,IPMASS,INF0,IPMODE,IALEAT,LIMAGE,INSYM) * * PARAMETRES: (E)=ENTREE (S)=SORTIE * ----------- * * FREQ REEL DP (E) FREQUENCE A APPROCHER PAR UNE FREQUENCE * PROPRE. * IPRIGI ENTIER (E) POINTEUR DE L'OBJET 'RIGIDITE' CONTENANT * LA MATRICE DE RIGIDITE. * IPMASS ENTIER (E) POINTEUR DE L'OBJET 'RIGIDITE' CONTENANT * LA MATRICE MASSE. * INF0 ENTIER (E) NOMBRE DE TERMES DIAGONAUX NEGATIFS DE LA * 'RIGIDITE' "K" DECOMPOSEE EN L.D.LT . * CE NOMBRE N'EST PAS NUL A CAUSE DE LA FACON * DONT SONT INTRODUITS LES BLOCAGES DES * D.D.L. (MULTIPLICATEURS DE LAGRANGE "LX"). * IPMODE ENTIER (S) POINTEUR DE L'OBJET 'SOLUTION' CONTENANT * LE MODE PROPRE TROUVE. * INSYM ENTIER (E) INDICATEUR DE LA NON SYMETRIE DE LA RIGIDITE * NON SYMETRIQUE: MODES COMPLEXES * MTAB3 TABLE (S) TABLE D'UN COUPLE SOLUTION * * LEXIQUE: (ORDRE ALPHABETIQUE) * -------- * * CONVRG LOGIQUE VOIR LE SOUS-PROGRAMME "ITINV". * FREDEC REEL DP FREQUENCE DE DECALAGE EFFECTIVE (EN GENERAL, * EGALE A "FREQ") * FREQPP REEL DP FREQUENCE PROPRE CALCULEE PROCHE DE "FREQ". * IPKW2M ENTIER POINTEUR DE LA 'RIGIDITE' "DECALEE" K - W2.M * IPRX ENTIER POINTEUR DU 'CHPOINT' QUI CONTIENT DES NOMBRES * ALEATOIRES, PUIS UN VECTEUR PROPRE REEL. * IPIX ENTIER POINTEUR DU 'CHPOINT' CONTENANT UN VECTEUR * PROPRE IMAGINAIRE EN FIN D'ITERATIONS * ITERMX ENTIER VOIR LE SOUS-PROGRAMME "ITINV". * NUMACC ENTIER VOIR LE SOUS-PROGRAMME "ITINV". * OMEGA2 REEL DP PULSATION PROPRE TROUVEE AU CARRE. * PRECI1 REEL SP VOIR LE SOUS-PROGRAMME "ITINV". * PRECI2 REEL SP VOIR LE SOUS-PROGRAMME "ITINV". * PROPRE REEL DP VOIR LE SOUS-PROGRAMME "ITINV". * W2 REEL DP PULSATION AU CARRE A APPROCHER. * * MODE DE FONCTIONNEMENT: * ----------------------- * * LE CALCUL D'UN VECTEUR PROPRE SE FAIT PAR LA METHODE DES * ITERATIONS INVERSES (DITE AUSSI DE LA PUISSANCE INVERSE), AVEC * DECALAGE INITIAL ("SHIFTING"). * * SOUS-PROGRAMMES APPELES: * ------------------------ * * ALEAT1, CREMOD, DECALE, DTRIGI, ECCHPO, ECSOLU, ERREUR, ITINV, * ITINVC, W2FREQ. * * AUTEUR, DATE DE CREATION: * ------------------------- * * PASCAL MANIGOT 16 OCTOBRE 1984 * * MODIFICATION *------------- * C. LE BIDEAU JUILLET 2001 * Benoit PRABEL MARS 2009 * * LANGAGE: * -------- * * FORTRAN77 + ESOPE * ************************************************************************ * IMPLICIT INTEGER(I-N) IMPLICIT REAL*8 (A-H,O-Z) -INC CCREEL -INC PPARAM -INC CCOPTIO -INC SMTABLE * PARAMETER (LPROPR = 10) * LOGICAL CONVRG,LIMAGE * REAL*8 PROPRE(LPROPR),PROPR2(LPROPR) * PARAMETER (ITERMX = 100) PARAMETER (PRECI1 = 1.D-10) PARAMETER (PRECI2 = 1.D-11) PARAMETER (DEUXPI = (2.D0*XPI)) PARAMETER (NUMACC = 999999) * * -- CREATION DE (K-W2M) -- * W2 = (FREQ * DEUXPI) ** 2 IF(LIMAGE) THEN W2 = SIGN(W2,FREQ) ENDIF CALL DECALE (IPRIGI,IPMASS, W2, IPKW2M) IF (IERR .NE. 0) RETURN * * -- INITIALISATION DES ITERATIONS: CREATION D'UN 'CHPOINT' * ALEATOIRE -- * IPRX = 0 * bp (03.2009) : si on souhaite eventuellement fournir 1 CHPOINT call LIROBJ('CHPOINT ',ICHP1,0,IRET1) if(IRET1.eq.0) then IF(IALEAT.EQ.0) CALL ALEAT1 (IPKW2M,IALEAT) IF (IERR.NE.0) RETURN CALL COPIE2(IALEAT,IPRX) else call ACTOBJ('CHPOINT ',ICHP1,1) CALL COPIE2(ICHP1,IPRX) endif C C CALCUL DE M*X C CALL MUCPRI(IPRX,IPMASS,IPMX) IF (IERR .NE. 0) RETURN IF (IIMPI .EQ. 747) THEN CALL ECCHPO (IPRX,0) END IF * * -- RESOLUTION PAR ITERATIONS INVERSES -- * IF (INSYM .EQ. 0) THEN CALL ITINV (IPKW2M,IPMASS,IPRX,PROPRE,CONVRG,ITERMX,NUMACC & ,PRECI1,PRECI2,IPMX) PROPRE(6) = 0.D0 IF (IERR .NE. 0) RETURN IF (.NOT.CONVRG) THEN INTERR(1) = ITERMX NUMERR = 151 CALL ERREUR (NUMERR) END IF ELSE CALL ITINVC (IPKW2M,IPMASS,IPRX,IPIX,PROPRE,CONVRG,ITERMX,IPMX) IF (IERR .NE. 0) RETURN IF (.NOT.CONVRG) THEN INTERR(1) = ITERMX NUMERR = 151 CALL ERREUR (NUMERR) END IF END IF * * -- NUMERO DU MODE -- *(relativement a W2=lambda^shift, puisque propre(1) est la valeur shiftée) -- * if(PROPRE(1) .lt. 0.) then NUMOD2 = 0 else NUMOD2 = 1 endif * * -- FREQUENCE PROPRE -- * IF (INSYM .EQ. 0 ) THEN CALL W2FREQ (PROPRE(1),W2, OMEGA2,FREQPP,LIMAGE) IF (IERR .NE. 0) RETURN PROPRE(1) = FREQPP ELSE CALL W2FRQC (PROPRE(1), PROPRE(6), W2, XRW2, XIW2, XRFREQ, & XIFREQ) IF (IERR .NE. 0) RETURN * on se débarasse des erreurs d'arrondis de W2FRQC if (PROPRE(6) .eq. 0.) then if ( (PROPRE(1) + W2) .lt. 0.) then PROPRE(1)= 0. PROPRE(6)= XIFREQ else PROPRE(1)= XRFREQ PROPRE(6)= 0. endif else PROPRE(1)= XRFREQ PROPRE(6)= XIFREQ endif END IF * IF (IIMPI .EQ. 747) THEN IF (INSYM .EQ. 0) THEN WRITE (IOIMP,*) 'FREQUENCE PROPRE CALCULEE = ',FREQPP WRITE (IOIMP,*) '-------------------------' WRITE (IOIMP,*) 'CHPOINT PROPRE:' CALL ECCHPO (IPRX,0) ELSE WRITE (IOIMP,*) 'FREQUENCE PROPRE REELLE CALCULEE = ',XRFREQ IF (PROPRE(6) .NE. 0) THEN WRITE (IOIMP,*) 'FREQUENCE PROPRE IMAGINAIRE CALCULEE = ' & ,XIFREQ END IF WRITE (IOIMP,*) '-------------------------' WRITE (IOIMP,*) 'CHPOINT PROPRE REEL:' CALL ECCHPO (IPRX,0) IF (PROPRE(6) .NE. 0) THEN WRITE (IOIMP,*) 'CHPOINT PROPRE IMAGINAIRE:' CALL ECCHPO (IPIX,0) END IF END IF END IF * * -- CREATION DE L'OBJET REPRESENTANT LE MODE -- * * NUMOD2 = 0 IF (INSYM .EQ. 0) THEN * CALL CREMOD (PROPRE,IPRX,IPKW2M,INF0,FREQ,NUMOD2,IPMODE) CALL CREMOD (PROPRE,IPRX,IPKW2M,INF0,NUMOD2,IPMODE) IF (IERR .NE. 0) RETURN ELSE * CALL CREBAS (PROPR2,IPIX,0,IPKW2M,INF0,FREQ,NUMOD2,MTAB3,I) CALL CREBAS (PROPRE,IPRX,IPIX,IPKW2M,INF0,NUMOD2,MTAB3,I) I = I + 1 * dans le Cas d'un mode Reel Double, * on a stocké dans IPIX le 2eme vecteur du sous espace if( ((PROPRE(6) .EQ. 0.) .or. (PROPRE(1) .EQ. 0.)) & .and. (IPIX .ne. 0) ) then do ipro2=1,LPROPR PROPR2(ipro2) = PROPRE(ipro2) enddo PROPR2(2)=PROPRE(7) * CALL CREBAS (PROPR2,IPIX,0,IPKW2M,INF0,FREQ,NUMOD2,MTAB3,I) CALL CREBAS (PROPR2,IPIX,0,IPKW2M,INF0,NUMOD2,MTAB3,I) I = I + 1 endif END IF * * IMPRESSION DU MODE: IF (IIMPI.EQ.2) THEN IF (INSYM .EQ. 0) THEN WRITE (IOIMP,2000) 2000 FORMAT ('1MODE PROPRE CALCULE:'/' --------------------'//) CALL ECMODE (IPMODE) ELSE CALL ECTABL (MTAB3) END IF ENDIF * * -- SUPPRESSION DES OBJETS DE TRAVAIL -- * CALL DTRIGI (IPKW2M) * END