Sources Esope | Cast3M

proch1
C PROCH1    SOURCE    CHAT      09/10/09    21:21:56     6519
C     SUBROUTINE PROCH1 (IPFREQ,IPNMOD,IPRIGI,IPMASS,IPSOLU,LIMAGE,IBASC,
C                INSYM)
************************************************************************
*
*                             P R O C H 1
*                             -----------
*
* FONCTION:
* ---------
*
*     EXECUTER LA FONCTION ATTRIBUEE A L'OPERATEUR "PROCHE".
*     VOIR LE SOUS-PROGRAMME "PROCHE".
*
* MODE D'APPEL:
* -------------
*
*     CALL  PROCH1 (IPFREQ,IPNMOD,IPRIGI,IPMASS,IPSOLU,LIMAGE)
*
* PARAMETRES:   (E)=ENTREE   (S)=SORTIE
* -----------
*
*     IPFREQ  ENTIER    (E)  POINTEUR DE L'OBJET 'LISTREEL' CONTENANT LA
*                            SUITE DE FREQUENCES A APPROCHER PAR DES
*                            FREQUENCES PROPRES.
*     IPNMOD  ENTIER    (E)  POINTEUR DE L'OBJET 'LISTENTI' CONTENANT LA
*                            SUITE DES ORDRES DE MULTIPLICITE DES FREQUENCES
*                            PROPRES
*     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.
*     IPSOLU  ENTIER    (S)  POINTEUR DE L'OBJET 'SOLUTION' CONTENANT
*                            LA SUITE DE MODES PROPRES SOLUTIONS.
*     INSYM   ENTIER         INDIQUE LA NON SYMETRIE DE LA MATRICE
*                            DE RIGIDITE
*     LIMAGE  BOOLEEN   (E)  VRAI SI ON SOUHAITE DES FREQ. NEGATIVES.
*     IBASC   TABLE     (S)  TABLE D'OBJETS SOLUTION CAS NON SYMETRIQUE
*
*
*
* AUTEUR, DATE DE CREATION:
* -------------------------
*
*     PASCAL MANIGOT     16 OCTOBRE 1984      (  ESOPE  )
*
* MODIFICATION :
*---------------
*     C. LE BIDEAU       JUILLET 2001
*     Benoit PRABEL      MARS 2009
*
************************************************************************
 
      SUBROUTINE PROCH1 (IPFREQ,IPNMOD,IPRIGI,IPMASS,IPSOLU,
     &           LIMAGE,IBASC, INSYM)
 
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
 
-INC PPARAM
-INC CCOPTIO
-INC  SMLREEL
-INC  SMLENTI
-INC  SMRIGID
-INC  SMTABLE
 
 
******
*     -- PARAMETRES --
***
      POINTEUR IPFREQ.MLREEL, IPNMOD.MLENTI , IBASC.MTABLE
      INTEGER  IPRIGI, IPMASS, IPSOLU,INF0,INSYM, NRG, NBR
      LOGICAL  LIMAGE
 
******
*     -- VARIABLES LOCALES --
***
      REAL*8  FREQ
      INTEGER NBFREQ, NBMOD, IB100, IPSOL1, IPMODE,  I
 
      INF0 = 0
      INSYM = 0
 
      SEGACT ,IPFREQ, IPNMOD
      NBFREQ = IPFREQ.PROG(/1)
******
*     --TEST DE LA SYMETRIE--
******
 
      MRIGID=IPRIGI
      SEGACT MRIGID*MOD
      NRG = IRIGEL(/1)
      NBR = IRIGEL(/2)
       IF(NBR.EQ.0) THEN
         SEGDES MRIGID
         CALL ERREUR(727)
         RETURN
       ENDIF
*
*
         IF (NRG.GE.7) THEN
C    ... On teste si la matrice contient des matrices non symétriques ...
*
*
         DO  9 IN = 1,NBR
            IANTI=IRIGEL(7,IN)
            IF(IANTI.GT.0) THEN
              IF(NORINC.NE.0.AND.NORIND.EQ.0) THEN
                  CALL ERREUR(760)
                  SEGDES,MRIGID
                  RETURN
               ENDIF
*
               INSYM = 1
            ENDIF
 9         CONTINUE
          END IF
*          WRITE(6,*)'INSYM = ',INSYM
*
******
*     -- POUR CHAQUE FREQUENCE --
***
*
      IF (INSYM .EQ. 1) THEN
      I = 1
      CALL CRTABL(IBASC)
      CALL ECCTAB(IBASC,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,0,
     & 'MOT',0,0.0D0,'TABLE_DE_MODES',.TRUE.,0)
      CALL CRTABL(MTAB3)
      CALL ECCTAB(IBASC,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,0,
     & 'MOT',0,0.0D0,'BASE_MODALE',.TRUE.,0)
*
******
*      CREATION DE L'OBJET SOLUTION
***
*
         CALL CRTABL(MTAB3)
         CALL ECCTAB(MTAB3,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.
     &        ,0,'MOT',0,0.0D0,'BASE_MODALE',.TRUE.,0)
 
      END IF
      DO 100 IB100=1,NBFREQ
         FREQ  = IPFREQ.PROG(IB100)
         NBMOD = IPNMOD.LECT(IB100)
******
*     -- RECHERCHE D'UN MODE ET AJOUT A L'ENSEMBLE DES MODES
*     DEJA TROUVES. POUR LES MODES SIMPLES, ON UTILISE LA
*     METHODE DE LA PUISSANCE INVERSE. POUR LES MODES MULTIPLES
*     L'ITERATION D'UN SOUS-ESPACE. --
***
         IF ( NBMOD .LE. 1 ) THEN
            IALEAT = 0
            CALL PROCH2 (FREQ,IPRIGI,IPMASS,INF0,IPMODE,IALEAT,LIMAGE,
     &      INSYM, MTAB3,I)
            IF ( IERR .NE. 0 ) RETURN
            if (IALEAT.ne.0)  CALL DTCHPO ( IALEAT )
         ELSE
           CALL PROCH3 (FREQ,NBMOD,IPRIGI,IPMASS,INF0,IPMODE,
     &      LIMAGE,INSYM, MTAB3, I)
         ENDIF
         IF ( IERR .NE. 0 ) RETURN
*
*
         IF (INSYM .EQ. 0 ) THEN
            IF (IB100 .EQ. 1) THEN
               IPSOLU = IPMODE
            ELSE
               CALL FUSOLU (IPSOLU, IPMODE, IPSOL1)
               IF ( IERR .NE. 0 ) RETURN
               CALL DESOLU(IPMODE)
               IF ( IERR .NE. 0 ) RETURN
               CALL DESOLU(IPSOLU)
               IF ( IERR .NE. 0 ) RETURN
               IPSOLU = IPSOL1
            ENDIF
****
**        SI MODES COMPLEXES, TABLES D'OBJETS SOLUTIONS
**        UN ELEMENT DE MBASC CORRESPOND A UN COUPLE SOLUTION
****
         ELSE
 
            CALL ECCTAB(IBASC,'MOT',0,0.0D0,'MODES',.TRUE.,0,
     &     'TABLE',0,0.0D0,' ',.TRUE.,MTAB3)
         END IF
  100  CONTINUE
       SEGDES ,IPFREQ, IPNMOD
       RETURN
       END