Sources Esope | Cast3M

crsol1
C CRSOL1    SOURCE    PV        22/04/25    21:15:02     11344          
************************************************************************
*
*                                CRSOL1
*                             -----------
*
* FONCTION:
* ---------
*
*     -- CONSTRUCTION D'UN OBJET SOLUTION, A PARTIR DE LA LISTE
*     DES FREQUENCES PROPRES ET DE CELLE DES MODES PROPRES.
*     LES LISTES SONT SUPPOSES TRIEES, LES FREQUENCES SHIFTEES,
*     ET LES MODES ORTHONORMALISES. --
*
* MODE D'APPEL:
* -------------
*
*     CALL   CRSOL1 (FREQ,IPLVAR,IPLVAI,IPLVER, IPLVEI, NBMOD, IPKW2M, IPMASS,
*     &      MTAB3, ICOMP, I)
*
* PARAMETRES:   (E)=ENTREE   (S)=SORTIE
* -----------
*
*     IPLVAR  ENTIER    (E)  POINTEUR DE L'OBJET 'LISTREEL' CONTENANT
*                            LA SUITE DES FREQUENCES PROPRES REELLES.
*     IPLVAI  ENTIER    (E)  POINTEUR DE L'OBJET 'LISTREEL' CONTENANT
*                            LA SUITE DES FREQUENCES IMAGINAIRES
*     IPLVER  ENTIER    (E)  POINTEUR DE L'OBJET 'LISTCHPO' CONTENANT
*                            LA SUITE DES MODES PROPRES REELS.
*     IPLVEI  ENTIER    (E)  POINTEUR DE L'OBJET 'LISTCHPO' CONTENANT
*                            LA SUITE DES MODES PROPRES IMAGINAIRES.
*     NBMOD   ENTIER    (E)  NOMBRE DE MODES A INSERER DANS LA SOLUTION
*                            ON A: NBMOD .LE. DIMENSION( IPLVAL )
*
*     IPKW2M, IPMASS    (E)  MATRICES DE RIGIDITE (DECALEE) ET DE MASSE
*
*     FREQ    REEL      (E)  FREQUENCE UTILISEE POUR LE DECALLAGE
*
*     MTAB3   ENTIER    (S)  POINTEUR SUR LA SOLUTION CREEE.
*
*
* AUTEUR, DATE DE CREATION:
* -------------------------
*
*     C. LE BIDEAU         09 / 2001  ( FORTRAN + ESOPE )
*     MODIF     Benoit Prabel    Mars 2009
*
***************************************************
*      SUBROUTINE CRSOL1 (FREQ,IPLVAR,IPLVAI,IPLVER, IPLVEI,
*     &           NBMOD,IPKW2M,IPMASS,MTAB3,ICOMP, I)
      SUBROUTINE CRSOL1 (W2,IPLVAR,IPLVAI,IPLVER,NBMOD,NBMOD2,
     &   IPKW2M,IPMASS,MTAB3,I,INF0)
 
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
 
 
-INC PPARAM
-INC CCOPTIO
-INC SMLCHPO
-INC SMLREEL
-INC SMLMOTS
-INC SMTABLE
-INC CCREEL
 
******
*     -- CONSTANTES --
***
      PARAMETER (LPROPR = 10)
      PARAMETER (DEUXPI = (2.D0*XPI))
 
******
*     -- ARGUMENTS --
***
      POINTEUR IPLVER.MLCHPO,IPLVAR.MLREEL,IPLVAI.MLREEL
      INTEGER NBMOD, IPKW2M, IPMASS
 
******
*     -- VARIABLES LOCALES --
***
      POINTEUR IPLMOX.MLMOTS, IPLMOY.MLMOTS
      INTEGER  IPMODE, IPSOL1
      REAL*8   W2, PROPRE(LPROPR),PROPR2(LPROPR),XRVP, XIVP
 
 
***** ACTIVATIONS ****************************************************
      SEGACT ,IPLVER, IPLVAR, IPLVAI
 
*-----initialisation
      NBNEG = 1
      NBPOS = 0
 
 
***** BOUCLE SUR LES MODES A ECRIRE **********************************
      JVEC = 0
*      DO 100 IB100 = 1, NBMOD
      DO 100 IB100 = 1, NBMOD2
 
        JVEC = JVEC + 1
 
*------ frequence propre
        XRVP = IPLVAR.PROG(JVEC)
        XIVP = IPLVAI.PROG(JVEC)
        PROPRE(1) = XRVP
        PROPRE(6) = XIVP
 
*------ numero du mode (indicé selon lambda)
*       NUMOD2 = JVEC - NNBMOD
        XLAMBR = (DEUXPI**2) * ((XRVP**2) - (XIVP**2))
*        WRITE(6,*) 'CRSOL1: mode',JVEC
*        WRITE(6,*) ' w=',XRVP,'+i',XIVP,'L=',XLAMBR,'W2=',W2
        if(XLAMBR .lt. W2) then
            NBNEG = NBNEG - 1
            NUMOD2 = NBNEG
        else
            NBPOS = NBPOS + 1
            NUMOD2 = NBPOS
        endif
*        write(6,*) 'NBNEG,NBPOS,NUMOD2=',NBNEG,NBPOS,NUMOD2
 
*------ partie reelle du vecteur propre
        IPRX = IPLVER.ICHPOI(JVEC)
 
*------ debut masse généralisée + eventuelle recup des mots utiles
        CALL MUCPRI ( IPRX, IPMASS, IPBXR )
        IF (IB100 .EQ. 1) THEN
          CALL CORRSP(IPMASS, IPRX, IPBXR, IPLMOX, IPLMOY)
        END IF
        CALL XTY1(IPRX, IPBXR, IPLMOX, IPLMOY, XRBXR)
        IF (IERR .NE. 0 ) RETURN
 
 
*------ Cas d'un mode Réel
        IF((XRVP .eq. 0.) .or. (XIVP .eq. 0.)) then
*          valeur propre w réelle pure ou imaginaire pure (car lambda réel pur)
*          vecteur propre reel = IPRX
           IPIX = 0
*          masse complexe généralisée
           PROPRE(2) = XRBXR
           PROPRE(7) = 0.D0
C          INTRODUCTION DES COEF. PI OU 2PI EVENTUELS + calcul DEPGEN
*           CALL MASGEN(XRVP,PROPRE)
           CALL DEPGEN(IPMASS, IPRX,      PROPRE, IPBXR, IPLMOX,IPLMOY)
 
*          Ecriture dans MTAB3 du I^eme mode
           CALL CREBAS (PROPRE, IPRX, IPIX, IPKW2M, INF0,
     &           NUMOD2, MTAB3, I)
            I = I+1
 
 
*------ Cas d'un mode Complexe
        ELSE
           IPIX = IPLVER.ICHPOI(JVEC + 1)
*          valeur et vecteur propre complexe',IPIX
*          fin du calcul de la masse complexe généralisée
           CALL XTY1(IPIX, IPBXR, IPLMOX, IPLMOY, XIBXR)
           CALL MUCPRI(IPIX, IPMASS, IPBXI)
           CALL XTY1(IPRX, IPBXI, IPLMOX, IPLMOY, XRBXI)
           CALL XTY1(IPIX, IPBXI, IPLMOX, IPLMOY, XIBXI)
           PROPRE(2) = XRBXR - XIBXI
           PROPRE(7) = XIBXR + XRBXI
*           write(*,*)'masse gene complexe=',(PROPRE(2)),(PROPRE(7))
C          INTRODUCTION DES COEF. PI OU 2PI EVENTUELS + calcul DEPGEN
           CALL DEPGEN(IPMASS, IPRX,      PROPRE, IPBXR, IPLMOX,IPLMOY)
           CALL DEPGE2(IPMASS, IPRX,IPIX, PROPRE, IPBXR, IPLMOX,IPLMOY)
*           write(*,*)'*          on decale JVEC...'
           JVEC = JVEC + 1
           if(XLAMBR .lt. W2) then
            NBNEG = NBNEG - 1
           else
            NBPOS = NBPOS + 1
           endif
 
*          Ecriture dans MTAB3 du I^eme mode
           CALL CREBAS (PROPRE, IPRX, IPIX, IPKW2M, INF0,
     &           NUMOD2, MTAB3, I)
            I = I+1
 
*          Ecriture dans MTAB3 du I+1^eme mode (=conjugué du 1er)
           PROPR2(1) = IPLVAR.PROG(JVEC)
           PROPR2(6) = IPLVAI.PROG(JVEC)
           PROPR2(2) = -1.*PROPRE(2)
           PROPR2(7) = -1.*PROPRE(7)
           call MUCHPO(IPIX,-1.D0,IPIXCONJ,1)
           CALL CREBAS (PROPR2, IPRX, IPIXCONJ, IPKW2M, INF0,
     &           NUMOD2, MTAB3, I)
            I = I+1
 
 
        ENDIF
*-------fin de la distinction Mode reel/complexe
 
 
         CALL DTCHPO ( IPBXR )
         if((XRVP .ne. 0.) .and. (XIVP .ne. 0.))
     &      CALL DTCHPO ( IPBXI )
 
 
         IF ( IERR .NE. 0 ) RETURN
 
         if(JVEC .ge. NBMOD2) goto 900
 
 100  CONTINUE
 
 900  CONTINUE
 
      SEGDES ,IPLVER, IPLVAR, IPLVAI
 
      RETURN
      END