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