Télécharger ricol1.eso

Retour à la liste

ricol1
C RICOL1    SOURCE    FANDEUR   22/01/19    21:15:15     11256          
C
C
      SUBROUTINE RICOL1(MLCHPO,ICLE,MRIGID,IPT1)
 
      IMPLICIT REAL*8 (A-H,O-Z)
      IMPLICIT INTEGER (I-N)
 
C***********************************************************************
C NOM         : RICOL1
C DESCRIPTION : Transforme les CHPOINTs d'un LISTCHPO en matrice colonne
c               pleine MRIGID avec les inconnues modales ALFA-FALF
C               et un maillage de POI1
C LANGAGE     : ESOPE
C
C AUTEUR, DATE, MODIF :
C  16/12/2014, Benoit Prabel : creation
C
C  ... merci de compléter les evolutions futures ...
C
C***********************************************************************
C ENTREES            : MLCHPO, IPT1 (+ autres lectures internes a ricolo)
C ENTREES/SORTIES    :
C SORTIES            : MRIGID
C***********************************************************************
 
-INC PPARAM
-INC CCOPTIO
-INC SMRIGID
-INC SMCHPOI
-INC SMELEME
-INC SMLCHPO
-INC SMCOORD
 
      CHARACTER*4 MOMOT(1)
      CHARACTER*8 LETYPE
      DATA MOMOT(1) /'TYPE'/
 
c***********************************************************************
c Executable statements
c***********************************************************************
 
 
c======================================================================c
c PRELIMINAIRES
 
 
c======================================================================c
c CREATION DE LA RIGIDITE DE SORTIE DEPUIS LE MELEME 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 IPT1 --
      SEGACT,IPT1
c     verif qu il s'agit dun maillage de POI1
      NBSOUS=IPT1.LISOUS(/1)
      IF(NBSOUS.NE.0) THEN
        WRITE(IOIMP,*) 'Maillage simple de POI1 attendu en entrée !'
        CALL ERREUR(25)
        RETURN
      ENDIF
      NBNN  =IPT1.NUM(/1)
      NBELEM=IPT1.NUM(/2)
      ITYP1 =IPT1.ITYPEL
      IF(NBNN.NE.1.OR.ITYP1.NE.1) THEN
        WRITE(IOIMP,*)  NBNN,NBELEM,' element de type ',ITYP1
        WRITE(IOIMP,*) 'Maillage de POI1 attendu en entrée !'
        CALL ERREUR(16)
        RETURN
      ENDIF
c     creation des MELEME,DESCR,XMATRI de la mrigid de sortie
      NLIGRP=NBELEM
      NLIGRD=NBELEM
      NELRIG=1
      NBNN=NBELEM
      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
*     on prend le type SUPERELEMENT a defaut d'autre chose...
      ITYPEL=28
      NBNO=0
      DO I=1,NBNN
        NUM(I,1)=IPT1.NUM(1,I)
        LISINC(I)='ALFA    '
        LISDUA(I)='FALF    '
        NOELEP(I)=I
        NOELED(I)=I
      ENDDO
      SEGDES,IPT1,DESCR
 
 
c======================================================================c
C BOUCLE SUR LES CHPOINTS : J=1..NJ
 
      SEGACT,MLCHPO
      NJ=ICHPOI(/1)
      IF(NJ.NE.NBNN) THEN
        write(ioimp,*) 'DIMENSION DU LISTCHPO INCOHERENTE AVEC LA ',
     &   'DESCRIPTION DES INCONNUES CONTENUE DANS LA RIGIDITE !'
        write(ioimp,*) NJ,NBNN
        CALL ERREUR(21)
        RETURN
      ENDIF
 
      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 RICOL1',iforie,ifopoi
            call erreur(1132)
            iforie = IFOUR
            MRIGID.IFORIG = iforie
          end if
        end if
 
c     on ouvre tout dans ce chpoint
        NSOUPO=IPCHP(/1)
        IF(NSOUPO.NE.1) THEN
          WRITE(IOIMP,*) 'LE CHPOINT DOIT AVOIR 1 SEULE ZONE !'
          CALL ERREUR(21)
          RETURN
        ENDIF
        ISOUPO=1
        MSOUPO = IPCHP(ISOUPO)
        SEGACT,MSOUPO
        NC=NOCOMP(/2)
        IF(NC.NE.1 .OR. NOCOMP(1).NE.'ALFA') THEN
          WRITE(IOIMP,*) 'LE CHPOINT DOIT AVOIR 1 COMPOSANTE : ALFA  !'
          CALL ERREUR(21)
          RETURN
        ENDIF
        IPT1   = IGEOC
        MPOVAL = IPOVAL
        SEGACT,IPT1,MPOVAL
c         WRITE(*,*) '1>>>>>>>1comp',MPOVAL.VPOCHA(1,1)
        IF(J.EQ.1) THEN
c         IF(ISOUPO.EQ.1) THEN
          IRIGEL(5,1) = NOHARM
c         ELSEIF(IRIGEL(5,1).NE.NOHARM) THEN
c           WRITE(IOIMP,*) 'CHPOINT AUX HARMONIQUES MULTIPLES NON TRAITES'
c           CALL ERREUR(21)
c           RETURN
c         ENDIF
        ENDIF
 
c======================================================================c
C BOUCLE SUR LES points DU CHPOINT : I=1..N
 
      N=VPOCHA(/1)
      DO 400 I=1,N
 
c       recup du noeud
        inode =  IPT1.NUM(1,i)
c       recherche de la position du noeud dans le MELEME de la rigidite
        DO ii=1,NBNN
          IF(NUM(ii,1).EQ.inode) GOTO 411
        ENDDO
        WRITE(IOIMP,*) 'Noeud',inode,'absent dans le MAILLAGE d entree'
        CALL ERREUR(21)
        RETURN
 
 411    CONTINUE
c       remplissage de XMATRI.RE
        RE(ii,J,1) = VPOCHA(I,1)
 
 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
 
 
      ENDDO
C     FIN DE BOUCLE SUR LES CHPOINTS
c======================================================================c
      SEGDES,MLCHPO
 
c***********************************************************************
C Normal termination
c***********************************************************************
      SEGDES,MELEME,XMATRI
      SEGDES,MRIGID
 
      RETURN
 
c***********************************************************************
c End of subroutine
c***********************************************************************
      END
 
 
 

© Cast3M 2003 - Tous droits réservés.
Mentions légales