Sources Esope | Cast3M

ricol2
C RICOL2    SOURCE    FANDEUR   22/01/19    21:15:15     11256          
C
C
      SUBROUTINE RICOL2(MLCHPO,ICLE,MRIGID,IVEC1)
 
      IMPLICIT REAL*8 (A-H,O-Z)
      IMPLICIT INTEGER (I-N)
 
C***********************************************************************
C NOM         : RICOL2
C DESCRIPTION : Transforme les CHPOINTs d'un LISTCHPO en matrice colonne
c               pleine MRIGID via un modele d'inconnu de IPRIG1
C               En pratique on fait une matrice pleine avec l'ordre des
C               inconnues contenues dans le mvecri de la rigidite modele
C               IPRIG1
C LANGAGE     : ESOPE
C
C AUTEUR, DATE, MODIF :
C  02/07/2014, Benoit Prabel : creation
C
C  ... merci de compléter les evolutions futures ...
C
C***********************************************************************
C ENTREES            : MLCHPO, IPRIG1 (+ autres lectures internes a ricolo)
C ENTREES/SORTIES    :
C SORTIES            : MRIGID
C***********************************************************************
 
 
-INC PPARAM
-INC CCOPTIO
-INC SMRIGID
-INC SMCHPOI
-INC SMELEME
-INC TMVECRIG
-INC SMLCHPO
-INC SMCOORD
 
      SEGMENT IDEJVU(NVU)
      CHARACTER*4 MOMOT(1)
      CHARACTER*8 LETYPE
      DATA MOMOT(1) /'TYPE'/
 
c***********************************************************************
c Executable statements
c***********************************************************************
 
c======================================================================c
c PRELIMINAIRES
 
      IDIM1=IDIM+1
c     segment pour ne traiter qu'une seule fois chaque point
      NVU=NBPTS
      SEGINI,IDEJVU
 
c======================================================================c
c CREATION DE LA RIGIDITE DE SORTIE DEPUIS LE MVECRI D ENTREE
 
      NRIGEL=1
      SEGINI,MRIGID
 
*     -- LECTURE DU SOUS-TYPE DE LA "RIGIDITE" A CREER --
      ITYP = 0
      CALL LIRMOT(MOMOT,1,ITYP,0)
      IF(ITYP.EQ.1) THEN
         ICODE = 1
         CALL LIRCHA (LETYPE,ICODE,IRETOU)
         IF (IERR .NE. 0) RETURN
      ELSE
C ... Si on n'a rien trouvé, on met un sous type par defaut dedans
        LETYPE='MONODROM'
      ENDIF
      MTYMAT=LETYPE
 
      COERIG(1)=1.D0
 
c     creation des objets depuis le mvecri
      MVECRI=IVEC1
      SEGACT,MVECRI
      nve=NUMZON(/1)
      NLIGRP=nve
      NLIGRD=nve
      NELRIG=1
      NBNN=nve
      NBELEM=1
      NBSOUS=0
      NBREF=0
      SEGINI,MELEME,DESCR,XMATRI
      IRIGEL(1,1)=MELEME
      IRIGEL(3,1)=DESCR
      IRIGEL(4,1)=XMATRI
      IRIGEL(7,1)=2
      xmatri.symre=2
      ITYPEL=28
      NBNO=0
 
c======================================================================c
C BOUCLE SUR LES CHPOINTS : J=1..NJ
 
      SEGACT,MLCHPO
      NJ=ICHPOI(/1)
      IF(NJ.NE.nve) THEN
        write(ioimp,*) 'DIMENSION DU LISTCHPO INCOHERENTE AVEC LA ',
     &   'DESCRIPTION DES INCONNUES CONTENUE DANS LA RIGIDITE !'
        write(ioimp,*) NJ,nve
        CALL ERREUR(21)
        RETURN
      ENDIF
      iforie = -99
      DO J = 1, NJ
        MCHPOI=ICHPOI(J)
        SEGACT,MCHPOI
        if (j.eq.1) then
          iforie = mchpoi.ifopoi
          MRIGID.IFORIG = iforie
        else
          if (iforie .NE. mchpoi.ifopoi) then
            interr(1)=iforie
            interr(2)=mchpoi.ifopoi
            interr(3)=IFOUR
c-dbg            write(ioimp,*) '1132 RICOL2',iforie,ifopoi
            call erreur(1132)
            iforie = IFOUR
            MRIGID.IFORIG = iforie
          end if
        end if
 
c     on ouvre tout dans ce chpoint
      NSOUPO=IPCHP(/1)
      DO 220 ISOUPO=1,NSOUPO
        MSOUPO = IPCHP(ISOUPO)
        SEGACT,MSOUPO
        IPT1   = IGEOC
        MPOVAL = IPOVAL
        SEGACT,IPT1,MPOVAL
c         WRITE(*,*) '1>>>>>>>1comp',MPOVAL.VPOCHA(1,1)
        IF(J.NE.1) GOTO 220
        IF(ISOUPO.EQ.1) THEN
          IRIGEL(5,1) = NOHARM
        ELSEIF(IRIGEL(5,1).NE.NOHARM) THEN
          WRITE(IOIMP,*) 'CHPOINT AUX HARMONIQUES MULTIPLES NON TRAITES'
          CALL ERREUR(21)
          RETURN
        ENDIF
 220  CONTINUE
 
 
c======================================================================c
C BOUCLE SUR LES INCONNUES DU CHPOINT : I=1..nve
 
      DO 400 I=1,nve
 
c       recup de la zone
        iz     = NUMZON(I)
        MSOUPO = IPCHP(iz)
        IPT1   = IGEOC
        MPOVAL = IPOVAL
 
c       inconnue : nom + numero
        IC = NUINLO(I)
        I1 = NUNOLO(I)
 
c       ce noeud a t'il deja été vu ?
        IP1  = IPT1.NUM(1,I1)
        IF(IDEJVU(IP1).EQ.0) THEN
          NBNO = NBNO + 1
          IDEJVU(IP1) = NBNO
c         si non, remplissage de MELEME
          NUM(NBNO,1) = IP1
          INO1 = NBNO
        ELSE
          INO1 = IDEJVU(IP1)
        ENDIF
 
c       remplissage de DESCR (seulement au 1er passage)
        IF(J.EQ.1) THEN
          LISINC(I) = NAMINC(iz,IC)
          LISDUA(I) = NAMDUA(iz,IC)
          NOELEP(I) = INO1
          NOELED(I) = INO1
        ENDIF
 
c       remplissage de XMATRI.RE
        RE(I,J,1) = VPOCHA(I1,IC)
 
 400  CONTINUE
 
 
c     on ferme tout dans ce chpoint
      DO 290 ISOUPO=1,NSOUPO
        MSOUPO = IPCHP(ISOUPO)
        IPT1   = IGEOC
        MPOVAL = IPOVAL
        SEGDES,IPT1,MPOVAL
        SEGDES,MSOUPO
 290  CONTINUE
      SEGDES,MCHPOI
 
      END DO
C     FIN DE BOUCLE SUR LES CHPOINTS
c======================================================================c
      SEGDES,MLCHPO
 
c***********************************************************************
C Normal termination
c***********************************************************************
      NBNN=NBNO
      SEGADJ,MELEME
      SEGDES,MELEME,DESCR,XMATRI
      SEGDES,MRIGID,MVECRI
      SEGSUP,IDEJVU
 
      RETURN
c***********************************************************************
c End of subroutine
c***********************************************************************
 
      END