C IDLIA1 SOURCE BP208322 14/09/15 21:16:39 8150 SUBROUTINE IDLIA1(ipm,ipr,ipt) c identifie les liaisons : point + ddl d'un objet rigidite c vis-à-vis d'un maillage c range dans une table IMPLICIT REAL*8 (A-H,O-Z) IMPLICIT INTEGER(I-N) -INC PPARAM -INC CCOPTIO -INC SMRIGID -INC SMTABLE -INC SMELEME c on autorise les ddl mecanique + thermique + liquide c rem : on pourrait utiliser lnomdd de bdata sans les alfa, beta PARAMETER (NPRIN=15) CHARACTER*4 MOPRIN(NPRIN) DATA MOPRIN / 'UX ','UY ','UZ ','UR ','UT ', & 'RX ','RY ','RZ ','RT ','P ','PI ', & 'T ','RR ','TINF','TSUP'/ CHARACTER*4 MOTINC INTEGER lpilmo(NPRIN) segment pilmpoi(0) c Recup des donnees d'entree + passage en POI1 du maillage entre meleme = ipm segact meleme if (itypel.ne.1) call change(ipm,1) meleme = ipm mrigid = ipr segact meleme,mrigid c creation de la table de sortie d'indice IM CALL CRTABL(ipt) CALL ECCTAB(ipt,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,0, & 'MOT',0,0.0D0,'LIAISONS_STATIQUES',.TRUE.,0) IM = 0 c creation segment local des noeuds par inconnue do l= 1,NPRIN segini pilmpoi lpilmo(l) = pilmpoi enddo c---- boucle sur les rigidites elementaires ---------------------------- nrigel = coerig(/1) DO 1 ire = 1,nrigel IPT1 = irigel(1,ire) segact ipt1 c on va demarrer a leun=2 si multiplicateur LX en 1ere position leun = 1 if (ipt1.itypel.eq.22) leun = 2 nbelem = ipt1.num(/2) descr = irigel(3,ire) segact descr NLIGRP = noelep(/1) IF(IIMPI.GE.333) WRITE(IOIMP,*) 'IDLI: zone ',ire,leun c ---- boucle sur les inconnues (primales) --------------------- DO 10 igrp = leun,NLIGRP MOTINC = lisinc(igrp) ino = noelep(igrp) IF(IIMPI.GE.333) WRITE(IOIMP,*) 'IDLI: inconnue',igrp,MOTINC,ino c recherche dans la liste l inconnue MOTINC do 11 l = 1,NPRIN if (MOTINC.eq.MOPRIN(l)) goto 12 11 continue c ici, on n'a pas trouve MOTINC c bp : soit on fait une erreur, soit on continue avec un avertissement c mais il ne faut pas s'arreter au milieu ... c MOTERR(1:4) = 'IDLI' c MOTERR(5:8) = MOTINC c CALL ERREUR(335) WRITE(IOIMP,*) 'IDLI: DDL NON TRAITE ', MOTINC goto 10 c ici, on a trouve MOTINC --> l IF(IIMPI.GE.333) WRITE(IOIMP,*) 'IDLI: retrouvee en position',l 12 continue pilmpoi = lpilmo(l) c ---- boucle sur les elements ---------------- DO 20 iele = 1,nbelem IPOI = ipt1.num(ino,iele) c recherche dans le maillage POI1 du noeud IPOI do 21 jn = 1,num(/2) if (IPOI.eq.num(1,jn)) goto 22 21 continue c ici, on n'a pas trouve IPOI : c on passe au noeud suivant sans mot dire goto 20 c ici, on a trouve IPOI -> jn et MOTINC -> l 22 continue IF(IIMPI.GE.333) WRITE(IOIMP,*) 'IDLI: et noeud',IPOI,' en',jn c IPOI a t'il deja ete vu pour l inconnue MOTINC(=l) ? do ip = 1,pilmpoi(/1) c si le couple IPOI + MOTINC deja vu => on ne retraite pas if (pilmpoi(ip).eq.IPOI) goto 10 enddo pilmpoi(**) = IPOI c on ecrit la table IPT . IM . POINT_LIAISON = IPOI c IPT . IM . DDL_LIAISON = MOTINC IM = IM + 1 CALL CRTABL(iptab2) CALL ECCTAB(iptab2,'MOT',0,0.0D0,'POINT_LIAISON',.TRUE.,0, & 'POINT',0,0.0D0,' ',.TRUE.,IPOI) CALL ECCTAB(iptab2,'MOT',0,0.0D0,'DDL_LIAISON',.TRUE.,0, & 'MOT',0,0.0D0,MOTINC,.TRUE.,0) CALL ECCTAB(IPT,'ENTIER',IM,0.0D0,' ',.TRUE.,0, & 'TABLE',0,0.0D0,' ',.TRUE.,iptab2) 20 continue c ---- fin de boucle sur les elements ---------------- 10 continue c ---- fin de boucle sur les inconnues (primales) --------------------- segdes ipt1,descr 1 CONTINUE c---- fin de boucle sur les rigidites elementaires --------------------- c suppression segment local avant de partir do io = 1,NPRIN pilmpoi = lpilmo(io) segsup pilmpoi enddo RETURN END