chame2
C CHAME2 SOURCE CB215821 20/11/25 13:19:17 10792 SUBROUTINE CHAME2(IPOGEO,IPCHPO,IPCHEL,IPCHAM,IPMINT,IPORE,MELE) ************************************************************************ * * c h a m e 2 * ----------- * * fonction: * --------- * transformation d'un champ par point en champ par element * transfert des composantes du chpoint vers le chamelem, * relativement a un maillage elementaire du modele * * modules utilises: * ----------------- * IMPLICIT INTEGER(I-N) -INC PPARAM -INC CCOPTIO -INC SMELEME -INC SMCHAML -INC SMCHPOI -INC SMCOORD * * parametres: (e)=entree (s)=sortie (+ = contenu dans un commun) * ----------- * * ipogeo (e) pointeur sur un maillage elementaire * ipchpo (e) pointeur sur le champ par point (suppose actif)(retour actif) * +idim (e) voir ccoptio * ipchel (e) pointeur sur le champ par element (suppose actif) * ipcham (s) pointeur sur un segment "mchaml" * = 0 si echec * ipmint (e) = 0 si la mchaml doit etre laisse aux noeuds * = sinon pointeur sur un segment s'integration * correspondant au support desire * ipore (e) = 0 sauf pour milieu poreux (nbre de noeuds) * * * variables: * ---------- * * mtri = segment de travail * npaket = donne en regard du numero d'un noeud,le numero de la * zone du chpoint a laquelle il appartient * nposit = donne en regard du numero d'un noeud,le numero du poi1 * dans la zone referencee ci-dessus * SEGMENT,MTRI INTEGER NPAKET(NX),NPOSIT(NX) ENDSEGMENT * * icntch = segment de travail (CoNTenu du CHpoint) * noeuds(i)=1 si le noeud i appartient au support du champ, sinon 0 * SEGMENT,ICNTCH INTEGER NOEUDS(NX) ENDSEGMENT * CHARACTER*(LOCOMP) LENAME * * auteur, date de creation: * ------------------------- * * denis robert,le 22 juin 1988. * * langage: * -------- * * esope + fortran77 * * Remarque : Le pointeur IPMINT doit etre ACTIF en ENTREE de CHAME2 * ---------- et son etat ne doit pas etre modifie (meme en SORTIE). * ************************************************************************ IPCHAM=0 * MCHPOI=IPCHPO NSOUPO=IPCHP(/1) * N2=10 n2r=0 call oooprl(1) SEGACT,MCOORD NX=XCOOR(/1)/(IDIM+1) SEGINI,MTRI,ICNTCH,MCHAML call oooprl(0) * IPT1=IPOGEO NBN1=IPT1.NUM(/1) NBELE1=IPT1.NUM(/2) * * boucle 1 sur les zones du chpoint * do 50 ISOUPO=1,NSOUPO MSOUPO=IPCHP(ISOUPO) MELEME=IGEOC NBELEM=NUM(/2) DO 60 IPOI=1,NBELEM IPONU=NUM(1,IPOI) NOEUDS(IPONU)=1 60 CONTINUE 50 continue * * boucle 2 sur les zones du chpoint * DO 100 ISOUPO=1,NSOUPO MSOUPO=IPCHP(ISOUPO) MPOVAL=IPOVAL MELEME=IGEOC NBELEM=NUM(/2) DO 107 IO=1,NX NPAKET(IO)=0 NPOSIT(IO)=0 107 CONTINUE * * boucle sur les poi1 contenus dans le msoupo considere * DO 110 IPOI=1,NBELEM IPONU=NUM(1,IPOI) NPAKET(IPONU)=ISOUPO NPOSIT(IPONU)=IPOI 110 CONTINUE * end do NCOMP=NOCOMP(/2) IMO=0 * * boucle sur les composantes du msoupo considere * DO 120 ICOMP=1,NCOMP IF (N2R.GT.0) THEN IF (IMO.EQ.0) THEN n2r=n2r+1 IF (N2R.GT.N2) then N2=n2+100 SEGADJ,MCHAML endif NOMCHE(N2r)=NOCOMP(ICOMP) TYPCHE(N2r)='REAL*8' * else *+* if (noharm(icomp).ne.nuhche(imo)) then * * c'est un nouvel harmonique * * n2=nomche(/2)+1 * segadj,mchaml * nomche(n2)=nocomp(icomp) * typche(n2)='real*8' * endif ENDIF ELSE N2R=N2R+1 IF (N2R.GT.N2) then N2=n2+100 SEGADJ,MCHAML endif NOMCHE(N2R)=NOCOMP(ICOMP) TYPCHE(N2R)='REAL*8' ENDIF * IF (IMO.EQ.0) THEN N1PTEL=NBN1 N1EL=NBELE1 N2PTEL=0 N2EL=0 SEGINI,MELVAL IELVAL(N2R)=MELVAL ELSE MELVAL=IELVAL(IMO) ENDIF * DO 220 IEL=1,NBELE1 DO 210 INOE=1,NBN1 IPONU=IPT1.NUM(INOE,IEL) ISOUP=NPAKET(IPONU) IF (ISOUP.NE.0) THEN * le point considere est reference dans ce maillage NPOPO=NPOSIT(IPONU) IF (NPOPO.NE.0) THEN VELCHE(INOE,IEL)=VPOCHA(NPOPO,ICOMP) ENDIF * else * if(noeuds(IPONU).eq.0) then * interr(1)=IPONU * call erreur(771) * endif ENDIF 210 CONTINUE * end do 220 CONTINUE * end do 120 CONTINUE * end do 100 CONTINUE * end do * N2=n2R SEGADJ,MCHAML * * changement de support si besoin est * Le segment IPMINT est suppose ACTIF (E/S) * IF (IPMINT.NE.0) THEN DO 400 ICOMP=1,N2 IPMELV=IELVAL(ICOMP) LENAME=NOMCHE(ICOMP) IELVAL(ICOMP)=IPRES * * MELVAL=IPRES * MELVAL=IPMELV SEGSUP,MELVAL 400 CONTINUE ENDIF * IPCHAM=MCHAML SEGSUP,MTRI,ICNTCH END
© Cast3M 2003 - Tous droits réservés.
Mentions légales