C CRSOLU    SOURCE    BP208322  09/03/20    21:15:09     6331           
C CRSOLU   SOURCE    WPAMJ       05/09/94
************************************************************************
*
*                                CRSOLU
*                             -----------
*
* 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   CRSOLU (FREQ,IPLVAL, IPLVEC, NBMOD, IPKW2M, IPMASS, IPSOLU)
*
* PARAMETRES:   (E)=ENTREE   (S)=SORTIE
* -----------
*
*     IPLVAL  ENTIER    (E)  POINTEUR DE L'OBJET 'LISTREEL' CONTENANT
*                            LA SUITE DES FREQUENCES PROPRES.
*     IPLVEC  ENTIER    (E)  POINTEUR DE L'OBJET 'LISTCHPO' CONTENANT
*                            LA SUITE DES MODES PROPRES.
*     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
*
*     IPSOLU  ENTIER    (S)  POINTEUR SUR LA SOLUTION CREE.
*
*
* AUTEUR, DATE DE CREATION:
* -------------------------
*
*     A.M. JOLIVALT, W. PASILLAS     06 / 07 / 94. ( ESOPE )
*
***************************************************
*      SUBROUTINE CRSOLU (FREQ,IPLVAL,IPLVEC,NBMOD,IPKW2M,IPMASS,
      SUBROUTINE CRSOLU (W2,IPLVAL,IPLVEC,NBMOD,IPKW2M,IPMASS,
     >           IPSOLU,INF0)

      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)

-INC CCOPTIO
-INC SMLCHPO
-INC SMLREEL
-INC SMLMOTS
-INC CCREEL

******
*     -- CONSTANTES --
***
      PARAMETER (LPROPR = 5)
      PARAMETER (DEUXPI = (2.D0*XPI))

******
*     -- ARGUMENTS --
***
      POINTEUR IPLVEC.MLCHPO, IPLVAL.MLREEL
      INTEGER NBMOD, IPKW2M, IPMASS, IPSOLU

******
*     -- VARIABLES LOCALES --
***
      POINTEUR IPLMD.MLMOTS, IPLMF.MLMOTS
      INTEGER  IPMX, IPMODE, IPSOL1
      REAL*8   OMEGA2, PROPRE(LPROPR), FREQ, XXTMX


******
*     -- LES MODES PROPRES CORRESPONDENT AUX COUPLES: --
*         ( IPLVAL(I) , IPLVEC(I) )    I = 1, NBMOD
***
      SEGACT ,IPLVEC, IPLVAL

*      NBMOD2 = 0
*      DO 10 IB100 = 1, NBMOD
*         FREQUI = IPLVAL.PROG(IB100)
*         IF (FREQUI.GE.FREQ) NBMOD2 = NBMOD2 + 1
* 10   CONTINUE
*
*      NNBMOD = NBMOD - NBMOD2
      NBNEG = 1
      NBPOS = 0

      DO 100 IB100 = 1, NBMOD
         IPVECP = IPLVEC.ICHPOI(IB100)
         CALL XTMX ( IPVECP, IPMASS, XXTMX )
         IF ( IERR .NE. 0 ) RETURN
         CALL MUCPRI ( IPVECP, IPMASS, IPMX )
         IF ( IERR .NE. 0 ) RETURN
         IF ( IB100 .EQ. 1 ) THEN
*           -- NOM DES COMPOSANTES: --
            CALL CORRSP ( ipmass, IPVECP, IPMX, IPLMD, IPLMF )
            IF ( IERR .NE. 0 ) RETURN
         ENDIF
*         NUMOD2 = IB100 - NNBMOD
         PROPRE(1) = IPLVAL.PROG(IB100)
         PROPRE(2) = XXTMX
         XLAMBR = sign( ((DEUXPI*PROPRE(1))**2) , PROPRE(1) )
         if(XLAMBR .lt. W2) then
            NBNEG = NBNEG - 1
            NUMOD2 = NBNEG
         else
            NBPOS = NBPOS + 1
            NUMOD2 = NBPOS
         endif
         CALL MASGEN ( IPVECP, PROPRE )
         IF ( IERR .NE. 0 ) RETURN
         CALL DEPGEN ( IPMASS, IPVECP, PROPRE, IPMX, IPLMD, IPLMF)
         IF ( IERR .NE. 0 ) RETURN
*         CALL CREMOD ( PROPRE,IPVECP,IPKW2M,INF0,FREQ,NUMOD2,IPMODE)
         CALL CREMOD ( PROPRE,IPVECP,IPKW2M,INF0,NUMOD2,IPMODE)
         IF ( IERR .NE. 0 ) RETURN
*        -- AFFICHAGE DE LA SOLUTION --
         IF ( IIMPI .EQ. 2 ) CALL ECMODE ( IPMODE )
         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
         CALL DTCHPO ( IPMX )
         IF ( IERR .NE. 0 ) RETURN
 100  CONTINUE

      IPMODE = IPSOLU

      SEGDES ,IPLVEC, IPLVAL

      SEGSUP ,IPLMD , IPLMF

      RETURN
      END