C ***************************************************************** C Delos est un mailleur automatique "surfacique" qui genere une C triangulation pour la simulation et/ou la visualisation. C C Licence et conditions d'utilisation de Delos. C C Copyright (C) 1994-2005 ARMINES/Ecole des Mines de Paris C C Ce programme est un logiciel libre ; vous pouvez le redistribuer C et/ou le modifier conformement aux dispositions de la Licence C Publique Generale GNU, telle que publiee par la Free Software C Fondation ; version 2 de la licence, ou encore (a votre choix) C toute version ulterieure. C C Ce programme est distribue dans l'esport qu'il sera utile, mais C SANS AUCUNE GARANTIE ; sans meme la garantie implicite de C COMMERCIALISATION ou D'ADAPTATION A UN OBJET PARTICULIER. Pour C plus de detail, voir la Licence Publique Generale GNU C C Vous devez avoir recu un exemplaire de la Licence Publique C Generale en meme temps que ce programme ; si ce n'est pas le cas, C ecrivez a la Free Software Fondation Inc.,675 Mass Ave,Cambridge, C MA 02139, Etats-Unis. C C Ce logiciel est telechargeable a l'adresse : C C http://www.ensmp.fr/~stab/delos C C vous trouverez egalement, sur ce site, un mode d'emploi complet et C des informations supplementaires. C C ***************************************************************** C *************************************************************** C MODULE : CG (CALCUL GEOMETRIQUE) C FICHIER : CG_DISTANCE.F C OBJET : CALCULS ELEMENTAIRES DE DISTANCES C A UN POINT, UN AXE. PROJECTIONS. C FONCT. : C C DIPOOB: DISTANCE D'UN POINT A UN OBJET C DIMONO: VERIFIE QUE LA DISTANCE A L'OBJET C EST UNE FONCTION MONOTONE SUR L'OBJET. C C FONCT. LOCALES : C DISPAX : DISTANCE D'UN POINT A UN AXE C DISPP : DISTANCE ENTRE 2 POINTS C DISPPL : DISTANCE ENTRE UN POINT ET UN PLAN C PRPOAX : PROJECTION D'UN POINT SUR UN AXE (LOCAL) C PRPOPN : PROJECTION D'UN POINT SUR UN PLAN (LOCAL) C PRJSEG : Abscisse du (projete) point XS sur le segment X1,X2 (LOCAL) C PRPOOB : PROJECTION D'UN POINT A UN OBJET (LOCAL) C DIMOSG : interface entre DIMONO et DIMOSG2 (LOCAL) C DIMOSG2 : points sur la droite XP1,XP2 ou la distance au seg S1,S2 "change" (LOCAL) C C AUTEUR : O. STAB C DATE : 03.95 / 06.95 C TESTS : 07.95 C MODIFICATIONS : C AUTEUR, DATE, OBJET : O.STAB, 27.10.97 BUG_40 DANS DISPSG ! C AUTEUR, DATE, OBJET : O.STAB, 19.04.01 BUG DANS DISPAX ! C AUTEUR, DATE, OBJET : O.STAB, 31.01.05 ajout DIMOSG, DIMOSG2 C (concentration sur un segment) C AUTEUR, DATE, OBJET : O.STAB, 13.09.06 BUG dans DIMOSG2 C AUTEUR, DATE, OBJET : O.STAB 28.06.2010 : reprise sur ERREUR dans DIMOSG2 C *************************************************************** C C FUNCTION DISPP(IDIMC,XP1,XP2) C *************************************************************** C OBJET DISPP : DISTANCE D'UN POINT A UN POINT (LOCAL) C *************************************************************** REAL DISPP INTEGER IDIMC REAL XP1(*),XP2(*) C REAL V12(3) COMMON /CGEPSI/ XYZHUG,XYZMIN,XYZEPS REAL XYZHUG,XYZMIN,XYZEPS C EXTERNAL SCALVE REAL SCALVE C CALL DIFFVE(XP2,XP1,IDIMC,V12) DISPP = SCALVE(V12,V12,IDIMC) DISPP = SQRT(DISPP) IF((DISPP.LT.XYZEPS).AND.(DISPP.GT.-XYZEPS))DISPP = 0.0 END C C FUNCTION DISPAX(IDIMC,XP1,XPA,VAX) C *************************************************************** C OBJET DISPAX : DISTANCE D'UN POINT A UN AXE (LOCAL) C XPA : UN POINT DE L'AXE C VAX : LE VECTEUR DIRECTEUR DE L'AXE (NORME) C *************************************************************** REAL DISPAX INTEGER IDIMC REAL XP1(*),XPA(*),VAX(*) C REAL V12(3),VPRV(3) COMMON /CGEPSI/ XYZHUG,XYZMIN,XYZEPS REAL XYZHUG,XYZMIN,XYZEPS C EXTERNAL SCALVE REAL SCALVE C CALL DIFFVE(XPA,XP1,IDIMC,V12) CALL VECTVE(V12,VAX,IDIMC,VPRV) DISPAX = ABS(VPRV(1)) C --- modif 19.04.2001 : BUG, on prenait la racine meme en 2D IF( IDIMC .EQ. 3 )THEN DISPAX = SCALVE(VPRV,VPRV,IDIMC) DISPAX = SQRT(DISPAX) ENDIF IF((DISPAX.LT.XYZEPS).AND.(DISPAX.GT.-XYZEPS))DISPAX = 0.0 END C C FUNCTION DISPSG(IDIMC,XP1,XPO,XPE) C *************************************************************** C OBJET DISPSG DISTANCE D'UN POINT A UN SEGMENT DE DROITE C XPO : LE POINT ORIGINE DU SEGMENT C XPE : LE POINT EXTREMITE DU SEGMENT C *************************************************************** REAL DISPSG INTEGER IDIMC REAL XP1(*),XPO(*),XPE(*) C REAL VO1(3),VOE(3),VPRJ(3),DO1,DOE COMMON /CGEPSI/ XYZHUG,XYZMIN,XYZEPS REAL XYZHUG,XYZMIN,XYZEPS C EXTERNAL SCALVE REAL SCALVE C CALL DIFFVE( XP1,XPO,IDIMC,VO1) CALL DIFFVE( XPE,XPO,IDIMC,VOE) DO1 = SCALVE(VO1,VOE,IDIMC) DOE = SCALVE(VOE,VOE,IDIMC) IF(DO1.LE.(XYZEPS*DOE))THEN C --- LE POINT LE PLUS PROCHE EST XPO --- DISPSG = SCALVE(VO1,VO1,IDIMC) ELSE IF(DO1.GE.((1.-XYZEPS)*DOE))THEN C --- LE POINT LE PLUS PROCHE EST XPE --- CALL DIFFVE( XPE,XP1,IDIMC,VO1) DISPSG = SCALVE(VO1,VO1,IDIMC) ELSE C --- LE PROJETE EST SUR LE SEGMENT --- CALL VECTVE(VO1,VOE,IDIMC,VPRJ) C ---- BUG_33.B : O.STAB, 17.10.97 : ERREUR SUR HP AVEC OPTION (+T) ---- IF(IDIMC.EQ.2)THEN C DISPSG = SQRT( VPRJ(1)*VPRJ(1) ) BUG_40, 27.10.97 O.STAB DISPSG = VPRJ(1)*VPRJ(1) ELSE DISPSG = SCALVE(VPRJ,VPRJ,IDIMC) ENDIF DISPSG = DISPSG / DOE ENDIF ENDIF C IF( DISPSG. LT. (XYZEPS**2) )THEN DISPSG = 0.0 ELSE DISPSG = SQRT(DISPSG) ENDIF 999 END C C FUNCTION DISPPL(IDIMC,XP1,XPP,VNP) C *************************************************************** C OBJET DISPPL : DISTANCE D'UN POINT A UN PLAN (LOCAL) C XPP : UN POINT DU PLAN C VNP : LE VECTEUR NORMAL AU PLAN (NORME) C *************************************************************** REAL DISPPL INTEGER IDIMC REAL XP1(*),XPP(*),VNP(*) C REAL V12(3) COMMON /CGEPSI/ XYZHUG,XYZMIN,XYZEPS REAL XYZHUG,XYZMIN,XYZEPS C EXTERNAL SCALVE REAL SCALVE C CALL DIFFVE( XPP,XP1,IDIMC,V12) DISPPL = SCALVE(V12,VNP,IDIMC) IF((DISPPL.LT.XYZEPS**2))THEN DISPPL = 0.0 ELSE DISPPL = SQRT(DISPPL) ENDIF END C SUBROUTINE DIPOOB(IDIMC,XP,ITYPE,ROBJET,D,IERR) C *************************************************************** C OBJET DIPOOB : DISTANCE D'UN POINT A UN OBJET C EN ENTREE : C IDIMC: DIMENSION DE L'ESPACE C XP : COORDONNEES DU POINT DONT ON CHERCHE LA DISTANCE C ITYPE: TYPE DE L'OBJET (1 = POINT, 2 = AXE, 3 = SEGMENT) C ROBJET : DEFINITION DE LA GEOMETRIE DE L'OBJET C EN SORTIE : C D : LA DISTANCE A L'OBJET C *************************************************************** INTEGER IDIMC,ITYPE,IERR REAL XP(*),ROBJET(*),D C EXTERNAL DISPP,DISPAX,DISPPL,XNORVE,DIFFVE,MUSCVE, > DISPSG REAL DISPP,DISPAX,DISPPL,XNORVE,DISPSG REAL VAX(3), XNORM COMMON /CGEPSI/ XYZHUG,XYZMIN,XYZEPS REAL XYZHUG,XYZMIN,XYZEPS C IERR = -1 GOTO (10,20,30,40) ITYPE GO TO 888 C --- POINT ------------ 10 IF( IDIMC .LT. 1 )GOTO 888 D = DISPP(IDIMC,XP,ROBJET) IERR = 0 GO TO 999 C --- AXE ----------- 20 IF( IDIMC .LT. 2 )GOTO 888 CALL DIFFVE(ROBJET(IDIMC+1),ROBJET,IDIMC,VAX) XNORM = XNORVE(VAX,IDIMC) IF( XNORM .LE. XYZMIN )GOTO 888 XNORM = 1.0 / XNORM CALL MUSCVE(VAX,XNORM,IDIMC,VAX) D = DISPAX(IDIMC,XP,ROBJET,VAX) IERR = 0 GO TO 999 C --- SEGMENT DE DROITE ------------- 30 IF( IDIMC .LT. 2 )GOTO 888 C PRINT *,'EN TEST' D = DISPSG(IDIMC,XP,ROBJET,ROBJET(IDIMC+1)) IERR = 0 GO TO 999 C --- PLAN ------------- 40 IF( IDIMC .LT. 3 )GOTO 888 C PRINT *,'A FAIRE' IERR = -3 C D = DISPPL(IDIMC,XP,ROBJET,VAX) C IERR = 0 GO TO 999 888 IF( IERR .NE. 0 )CALL DSERRE(1,IERR,'CG','DANS DIPOOB') 999 END C C SUBROUTINE PRPOAX(IDIMC,XP1,XPA,VAX,XPRJ) C *************************************************************** C OBJET PRPOAX : PROJECTION D'UN POINT SUR UN AXE (LOCAL) C XPA : UN POINT DE L'AXE C VAX : LE VECTEUR DIRECTEUR DE L'AXE (NORME) C *************************************************************** INTEGER IDIMC REAL XP1(*),XPA(*),VAX(*),XPRJ(*) C REAL V12(3),VPRJ(3),XDPA COMMON /CGEPSI/ XYZHUG,XYZMIN,XYZEPS REAL XYZHUG,XYZMIN,XYZEPS C EXTERNAL SCALVE REAL SCALVE C CALL DIFFVE( XPA,XP1,IDIMC,V12) XDPA = SCALVE(V12,VAX,IDIMC) IF((XDPA.LT.XYZEPS).AND.(XDPA.GT.-XYZEPS))XDPA = 0.0 CALL MUSCVE( VAX, XDPA, IDIMC, VPRJ ) CALL DIFFVE( VPRJ, XPA, IDIMC, XPRJ ) END C C SUBROUTINE PRPOPN(IDIMC,XP1,XPP,VNP,XPRJ) C *************************************************************** C OBJET PRPOPN : PROJECTION D'UN POINT SUR UN PLAN (LOCAL) C XPP : UN POINT DU PLAN C VNP : LE VECTEUR NORMAL AU PLAN (NORME) C *************************************************************** INTEGER IDIMC REAL XP1(*),XPP(*),VNP(*),XPRJ(*) C REAL V12(3),VPN12(3),VPRJ(3) C EXTERNAL NULLVE INTEGER NULLVE C IF( IDIMC .LT. 3 )THEN CALL COPIVE(XP1,IDIMC,XPRJ) GO TO 999 ENDIF C --- PROJECTION SUR LE PLAN --- CALL DIFFVE(XP1,XPP,IDIMC,V12) CALL VECTVE(V12,VNP,IDIMC,VPN12) IF(NULLVE(VPN12,IDIMC).NE.1)THEN CALL VECTVE(VNP,VPN12,IDIMC,VPRJ) CALL SOMMVE(XPP,VPRJ,IDIMC,XPRJ) ELSE CALL COPIVE(XPP,IDIMC,XPRJ) ENDIF C 999 END C C SUBROUTINE PRJSEG(XS,X1,X2,IDIMC,XSA) C ***************************************************** C OBJET PRJSEG : Abscisse du (projete) point XS sur le segment X1,X2 (LOCAL) C XSA : abscisse du point XS sur le segment X1,X2 C ***************************************************** REAL XS(*),X1(*),X2(*) INTEGER IDIMC REAL XSA C EXTERNAL SCALVE REAL X12(3),XSC(3),SCALVE,X12N C CALL DIFFVE(XS,X1,IDIMC,XSC) CALL DIFFVE(X2,X1,IDIMC,X12) XSA = SCALVE(X12,XSC,IDIMC) X12N = SCALVE(X12,X12,IDIMC) XSA = XSA / X12N 9999 END C C SUBROUTINE PRPOOB(IDIMC,XP,ITYPE,ROBJET,XPRJ,IERR) C *************************************************************** C OBJET PRPOOB : PROJECTION D'UN POINT A UN OBJET (LOCAL) C EN ENTREE : C IDIMC: DIMENSION DE L'ESPACE C XP : COORDONNEES DU POINT DONT ON CHERCHE LA DISTANCE C ITYPE: TYPE DE L'OBJET (1 = POINT, 2 = AXE, 3 = PLAN) C ROBJET : DEFINITION DE LA GEOMETRIE DE L'OBJET C EN SORTIE : C D : LA DISTANCE A L'OBJET C *************************************************************** INTEGER IDIMC,ITYPE,IERR REAL XP(*),ROBJET(*),XPRJ(*) C IERR = -1 GOTO (10,20,30) ITYPE GO TO 999 C --- POINT ------------ 10 IF( IDIMC .LT. 1 )GOTO 999 CALL COPIVE(XP,IDIMC,XPRJ) IERR = 0 GO TO 999 C --- AXE ----------- 20 IF( IDIMC .LT. 2 )GOTO 999 CALL PRPOAX(IDIMC,XP,ROBJET,ROBJET(IDIMC),XPRJ) IERR = 0 GO TO 999 C --- PLAN ------------- 30 IF( IDIMC .LT. 3 )GOTO 999 CALL PRPOPN(IDIMC,XP,ROBJET,ROBJET(IDIMC),XPRJ) IERR = 0 GO TO 999 999 END C C SUBROUTINE DIMONO(XP1,XP2,IDIMC,ITYPO,ROBJET, > XPNUL,MONO,IERR) C **************************************************************** C OBJET DIMONO : DISTANCE A L'OBJET MOMOTONE SUR LE SEGMENT ? C EN ENTREE : C XP1,XP2 : EXTREMITES DU SEGMENT C IDIMC : DIMENSION DE L'ESPACE C --------------------- C ITYPO : TYPE DE L'OBJET (de concentration) C ROBJET : LA DEFINITION GEOMETRIQUE DE L'OBJET C EN SORTIE : C MONO : 0 SI MONOTONE C > 0 nombre de points dans XPNUL C XPNUL : COORDONNEES des POINTS sur XP1,XP2 C anciennement : modif O.Stab 19.01.2005 C MONO : 1 SI MONOTONE 0 SINON C XPNUL : COORDONNEES DU POINT OU LA DERIVEE S'ANNULE C **************************************************************** REAL XP1(*),XP2(*) INTEGER IDIMC,ITYPO REAL ROBJET(*),XPNUL(*) INTEGER MONO,IERR C COMMON /CGEPSI/ XYZHUG,XYZMIN,XYZEPS REAL XYZHUG,XYZMIN,XYZEPS REAL PO(3),OE(3),XL,DROITE(3) EXTERNAL DIFFVE,SOMMVE,MUSCVE INTEGER INTER, INDRSE EXTERNAL INDRSE C IERR = 0 MONO = 0 GOTO( 10,60,120,180 ) ITYPO IERR = -1 GOTO 888 C ====================== C --- L'OBJET EST UN POINT --- ITYPO=1 C ====================== 10 CALL DIFFVE(XP1,ROBJET,IDIMC,PO) CALL DIFFVE(XP2,XP1,IDIMC,OE) C --- CAS 1D, 2D, 3D --- GOTO (20,30,40) IDIMC IERR = -1 GOTO 888 20 XL = OE(1) IF(( XL.GE.-XYZMIN ).AND.( XL.LE.XYZMIN ))THEN IERR = -1 GOTO 888 ENDIF XL = -PO(1) / XL GOTO 50 30 XL = (OE(1)**2+OE(2)**2) IF(( XL.GE.-XYZMIN ).AND.( XL.LE.XYZMIN ))THEN IERR = -1 GOTO 888 ENDIF XL = -(PO(1)*OE(1)+PO(2)*OE(2))/ XL GOTO 50 40 XL = (OE(1)**2+OE(2)**2+OE(3)**2) IF(( XL.GE.-XYZMIN ).AND.( XL.LE.XYZMIN ))THEN IERR = -1 GOTO 888 ENDIF XL=-(PO(1)*OE(1)+PO(2)*OE(2)+PO(3)*OE(3))/XL GOTO 50 C 50 IF((XL.GE.(1.-XYZEPS)).OR.(XL.LE.XYZEPS))GOTO 999 C PRINT *,' NON MONOTONE EN : ',XL MONO = 1 CALL MUSCVE(OE,XL,IDIMC,OE) CALL SOMMVE(XP1,OE,IDIMC,XPNUL) GOTO 999 C ======================== C --- L'OBJET EST UNE DROITE --- ITYPO=2 C ======================== C --- CAS 1D, 2D, 3D --- 60 GOTO (70,80,90) IDIMC 70 IERR = -1 GOTO 888 C --- INTERSECTION D'UNE DROITE ET D'UN SEGMENT --- 80 CALL DR2PO(ROBJET,ROBJET(IDIMC+1),DROITE,IERR) IF( IERR.NE. 0 )GOTO 888 INTER = INDRSE(XP1,XP2,DROITE,0,XPNUL,IERR) IF( IERR .NE. 0 )GOTO 888 IF( INTER .EQ. 1 )MONO = 1 GOTO 100 C --- DISTANCE MINI. ENTRE UNE DROITE ET UN SEGMENT --- 90 IERR = -3 C PRINT *,'A FAIRE' GOTO 888 100 GOTO 999 C ======================== C --- L'OBJET EST UN SEGMENT --- ITYPO=3 C ======================== 120 GOTO (130,140,150) IDIMC 130 IERR=-1 GOTO 888 C --- DIST. MINI. ENTRE 2 SEGMENTS --- C C PB : IL PEUT Y AVOIR 2 MINIMUMS PAR EXEMPLE C DANS LE CAS DE 2 SEGMENT PARALLELES OU C L'UN EST INCLUS DANS L'AUTRE. C C --- DIST. MINI. ENTRE 2 SEGMENTS --- 140 CONTINUE CALL DIMOSG(XP1,XP2,IDIMC,ROBJET,ROBJET(IDIMC+1), > XPNUL,MONO,IERR) C IF( IERR .NE. 0 )GOTO 888 C PRINT *,'CAS DU SEGMENT EN TEST !!!!' GOTO 888 150 IERR = -3 C PRINT *,'A FAIRE' IERR = -3 GOTO 888 C ======================== C --- L'OBJET EST UN PLAN --- C ======================== 180 IF( IDIMC.NE.3 )IERR = -1 C --- INTERSECTION D'UN PLAN AVEC UN SEGMENT --- C PRINT *,'A FAIRE' IERR = -3 GOTO 888 C 888 IF( IERR .NE. 0 )CALL DSERRE(1,IERR,'CG','DANS DIMONO') 999 END C C C SUBROUTINE DIMOSG(XP1,XP2,IDIMC,S1,S2, > XPNUL,MONO,IERR) C **************************************************************** C OBJET DIMOSG : interface entre DIMONO et DIMOSG2 (LOCAL) C **************************************************************** REAL XP1(*),XP2(*),S1(*),S2(*) INTEGER IDIMC REAL XPNUL(*) INTEGER MONO,IERR C REAL XPPP(3),XPSEG(4*3),V12(3) INTEGER I,NBS,ICASE C CALL DIMOSG2(XP1,XP2,IDIMC,S1,S2, > XPPP,XPSEG,NBS,ICASE,IERR) IF( IERR .NE. 0 )GOTO 888 MONO =0 C --- monotone IF(ICASE.EQ.0)GOTO 9999 C CALL DIFFVE(XP2,XP1,IDIMC,V12) C --- il n'y a pas de plus proche voisin pour ICASE=4 IF(ICASE.NE.4)THEN MONO = MONO+1 CALL MUSCVE(V12,XPPP,IDIMC,XPNUL((MONO-1)*IDIMC+1)) CALL SOMMVE(XP1,XPNUL,IDIMC,XPNUL((MONO-1)*IDIMC+1)) ENDIF DO 142 I=1,NBS MONO=MONO+1 CALL MUSCVE(V12,XPSEG(I),IDIMC,XPNUL((MONO-1)*IDIMC+1)) CALL SOMMVE(XP1,XPNUL((MONO-1)*IDIMC+1),IDIMC, > XPNUL((MONO-1)*IDIMC+1)) 142 CONTINUE 888 IF( IERR .NE. 0 )CALL DSERRE(1,IERR,'DIMOSG','APPEL DIMOSG2 ') 9999 END C SUBROUTINE DIMOSG2(XP1,XP2,IDIMC,S1,S2, > XPPP,XSEG,NBS,ICASE,IERR) C **************************************************************** C OBJET DIMOSG2 : points sur la droite XP1,XP2 ou la distance au seg S1,S2 "change" (LOCAL) C C EN ENTREE : C XP1,XP2 : le segment a tester C S1,S2 : le segment "site" (concentration) C EN SORTIE : C XPNODE(NBNODE) : abscisse des points de redecoupage C du segment XP1,XP2 C ICASE : 0 = monotone sur le segment XP1,XP2 C 1 = intersection du segment S1,S2 avec le segment XP1,XP2 C 2 = S1 est le point le plus proche de XP1,XP2 C 3 = S2 est le point le plus proche de XP1,XP2 C 4 = segment // a la droite (ou confondu) C 5 = segment perpendiculaire C C REMARQUE : ne fonctionne qu'en 2D pour l'instant !!!??? C **************************************************************** REAL XP1(*),XP2(*),S1(*),S2(*) INTEGER IDIMC REAL XPPP,XSEG(*) INTEGER NBS,ICASE,IERR C REAL APS1,APS2,AIS1,AIS2,AISMIN,AISMAX,APS12 REAL SP1(2),SP2(2),XIS1(2),XIS2(2),XS12(2) INTEGER INTER C C COMMON /CGEPSI/ XYZHUG,XYZMIN,XYZEPS,XYZHU2,XYZMI2 C REAL XYZHUG,XYZMIN,XYZEPS,XYZHU2,XYZMI2 COMMON /CGEPSI/ XYZHUG,XYZMIN,XYZEPS REAL XYZHUG,XYZMIN,XYZEPS C ICASE = -1 IERR = 0 NBS = 0 IF( IDIMC.NE.2 )THEN IERR = -3 GOTO 9999 ENDIF C 1. calcul de PS1,PS2 C -------------------- C PS1,PS2 <-projete de S1 et S2 sur XP1,XP2 CALL PRJSEG(S1,XP1,XP2,IDIMC,APS1) CALL PRJSEG(S2,XP1,XP2,IDIMC,APS2) C si PS1=PS2 les segments sont perpendiculaires C IF( ABS(APS1-APS2).LT.XYZEPS)THEN C BUG 13.09.06 O.STAB C .00000096 > 1.1920929e-07 et intersection pas detecte INDRDR !!! C FINALEMENT : comme APS1 sans unite = (PS1-XP1)/(XP2-XP1) C BUG 28.06.2010 : reprise sur ERREUR C on suppose segments perpendiculaires si INDRDR ne detecte pas d'intersection C TODO pour etre coherent avec INDRDR : ABS(S1SP2 n XP1XP2) < XYZEPS C ABS(APS1-APS2).LT.XYZEPS*norm(S1S2) IF( ABS(APS1-APS2).LT.0.0001)THEN GOTO 100 ENDIF C C 2. calcul de IS1,IS2 C -------------------- C IS1,IS2 <-intersection (Perpen en S1 avec XP1,XP2) C si PS1 = S1 (S1 est sur le segment XP1,XP2) IS1=PS1=S1 C SP2 est le point tel que : C S1,SP2 est le segment passant par S1 et perpendiculaire a S1,S2 SP2(1) = S2(2)-S1(2)+S1(1) SP2(2) = S1(1)-S2(1)+S1(2) CALL INDRDR(S1,SP2,XP1,XP2,IDIMC,XIS1,INTER) IF(INTER.NE.1)THEN C --- reprise sur le bug : si perpendiculaire IF(INTER.EQ.0)THEN GOTO 100 ENDIF C --- il y a un bug !!! CALL INDRDR(S1,SP2,XP1,XP2,IDIMC,XIS1,INTER) IERR = -1 GOTO 9999 ENDIF CALL PRJSEG(XIS1,XP1,XP2,IDIMC,AIS1) C ---idem PS2 C S2,SP1 est le segment passant par S2 et perpendiculaire a S1,S2 SP1(1) = S2(2)-S1(2)+S2(1) SP1(2) = S1(1)-S2(1)+S2(2) CALL INDRDR(S2,SP1,XP1,XP2,IDIMC,XIS2,INTER) IF(INTER.NE.1)THEN C --- reprise sur le bug : si perpendiculaire IF(INTER.EQ.0)THEN GOTO 100 GOTO 9999 ENDIF C --- il y a un bug !!! CALL INDRDR(S2,SP1,XP1,XP2,IDIMC,XIS2,INTER) IERR = -1 GOTO 9999 ENDIF CALL PRJSEG(XIS2,XP1,XP2,IDIMC,AIS2) C --- XPNODE <-stocker IS1, IS2 NBS = 0 IF((AIS1.GT.XYZEPS).AND.(AIS1.LT.1+XYZEPS))THEN NBS = NBS+1 XSEG(NBS)= AIS1 ENDIF IF((AIS2.GT.XYZEPS).AND.(AIS2.LT.1+XYZEPS))THEN NBS = NBS+1 XSEG(NBS)= AIS2 ENDIF C C 3b. stockage de PS1, PS2 C ------------------------- C --- si IS1=PS1 et IS2=PS2 les segments sont // IF((ABS(AIS1-APS1).LT.XYZEPS).AND.(ABS(AIS2-APS2).LT.XYZEPS))THEN C les vecteurs sont // ICASE = 4 GOTO 9999 ENDIF ICASE = 0 AISMIN =MIN(AIS1,AIS2) AISMAX =MAX(AIS1,AIS2) C --- si PS1 hors [IS1,IS2] XPNODE <-stocker PS1 C PS1 est le point le plus proche de la droite XP1,XP2 IF((APS1.LT.AISMIN).OR.(APS1.GT.AISMAX))THEN IF((APS1.GT.XYZEPS).AND.(APS1.LT.1+XYZEPS))THEN XPPP = APS1 ICASE = 2 ENDIF ENDIF C PS2 est le point le plus proche de la droite XP1,XP2 IF((APS2.LT.AISMIN).OR.(APS2.GT.AISMAX))THEN IF((APS2.GT.XYZEPS).AND.(APS2.LT.1+XYZEPS))THEN XPPP = APS2 ICASE = 3 ENDIF ENDIF C C 4. calcul de IX12 C -------------------- C XS12 <-intersection (XP1,XP2) avec (S1,S2) C si XS12 dans [PS1,PS2] XPNODE <-stocker XS12 CALL INDRDR(S1,S2,XP1,XP2,IDIMC,XS12,INTER) CALL PRJSEG(XS12,XP1,XP2,IDIMC,APS12) IF((APS12.GT.AISMIN).AND.(APS12.LT.AISMAX))THEN IF((APS12.GT.XYZEPS).AND.(APS12.LT.1+XYZEPS))THEN XPPP = APS12 ICASE = 1 ENDIF ENDIF GOTO 9999 C 100 CONTINUE C --------- SEGMENTS PERPENDICULAIRES : XP1,XP2 et S1,S2 ---------- C si PS1=PS2 les segments sont perpendiculaires C --- point "d'intersection" : IX12=PS1=PS2 XPPP = (APS1+APS2)/2.0 ICASE = 5 C IF((XPPP.LT.XYZEPS).OR.(XPPP.GT.1+XYZEPS))ICASE=0 C --- doutes : pourquoi les tests pas interieur tous les 2 ??? IF((XPPP.LT.XYZEPS).OR.(XPPP.GT.1+XYZEPS))ICASE=0 C 9999 END C C ***************************************************************** C MODULE : CG (CALCUL GEOMETRIQUE) C FICHIER : CG_DROITE.F C OBJET : GEOMETRIE 2D - CALCULS SUR LES DROITES C FONCT. : C DR2PO : CALCULE LA DROITE PASSANT PAR LES 2 POINTS C INDRDR : intersection de 2 droites C C FONCT. LOCALES : C PVDROI : CALCULE UN POINT ET LE VECTEUR DE LA DROITE (LOCAL) C INDRSE : INTERSECTION D'UNE DROITE ET D'UN SEGMENT (LOCAL) C C AUTEUR : O. STAB C DATE : 06.95 C TESTS : 07.95 C MODIFICATIONS : C AUTEUR, DATE, OBJET : O.STAB, 16.04.97, BUG_19 DANS PVDROI C IL FAUT TESTER ABS(DROITE(3)) C AUTEUR, DATE, OBJET : O.STAB, 31.01.05 ajout INDRDR C C C ***************************************************************** C C SUBROUTINE PVDROI( DROITE, XPOINT,VDIR, IERR ) C ***************************************************************** C OBJET PVDROI : CALCULE UN POINT ET LE VECTEUR DE LA DROITE 2D (LOCAL) C EN ENTREE : C DROITE : EQUATION DE LA DROITE AX+BY+C = 0 C EN SORTIE : C XPOINT : UN POINT DE LA DROITE C VDIR : LE VECTEUR DIRECTEUR DE LA DROITE C IERR : 0 SI OK, -1 SI "DROITE" N'EST PAS CORRECTE C ***************************************************************** REAL DROITE(3),XPOINT(2),VDIR(2) INTEGER IERR C COMMON /CGEPSI/ XYZHUG,XYZMIN,XYZEPS REAL XYZHUG,XYZMIN,XYZEPS C IERR = 0 C ---- BUG_19, O.STAB, 16.04.97 : AJOUT DE ABS --- IF((DROITE(1).GT.XYZEPS*ABS(DROITE(3))).OR. > (DROITE(1).LT.-XYZEPS*ABS(DROITE(3))))THEN XPOINT(1) = - DROITE(3) / DROITE(1) XPOINT(2) = 0.0 ELSE IF((DROITE(2).GT.XYZEPS*ABS(DROITE(3))).OR. > (DROITE(2).LT.-XYZEPS*ABS(DROITE(3))))THEN XPOINT(1) = 0.0 XPOINT(2) = - DROITE(3) / DROITE(2) ELSE IERR = -1 ENDIF ENDIF VDIR(1) = -DROITE(2) VDIR(2) = DROITE(1) 999 END C C INTEGER FUNCTION INDRSE(XP1,XP2,DROITE,ITEST,XPI,IERR) FUNCTION INDRSE(XP1,XP2,DROITE,ITEST,XPI,IERR) C ***************************************************************** C OBJET INDRSE : INTERSECTION D'UNE DROITE ET D'UN SEGMENT 2D C EN ENTREE : C XP1 : L'ORIGINE DU SEGMENT C XP2 : L'EXTREMITE DU SEGMENT C DROITE : L'EQUATION DE LA DROITE C ITEST : SI ITEST=1 ON NE CALCULE PAS LA POSITION DU POINT C EN SORTIE : RENVOI 1 SI INTERSECTION 0 SINON C XPI : POSITION DU POINT D'INTERSECTION (SI ITEST=1) C IERR : 0 SI OK, -1 SI "DROITE" N'EST PAS CORRECTE C ***************************************************************** INTEGER INDRSE REAL XP1(2),XP2(2),XPI(2) REAL DROITE(3) INTEGER ITEST,IERR C COMMON /CGEPSI/ XYZHUG,XYZMIN,XYZEPS REAL XYZHUG,XYZMIN,XYZEPS REAL S1,S2 REAL XPD(2),V12(2),V23(2),V2S(2),VDIR(2),X,SCALVE EXTERNAL SCALVE C ======================== C --- TEST DE L'INTERSECTION --- C ======================== S1 = DROITE(1)*XP1(1)+DROITE(2)*XP1(2)+DROITE(3) S2 = DROITE(1)*XP2(1)+DROITE(2)*XP2(2)+DROITE(3) IF(((S1.LE.-XYZEPS).AND.(S2.GE.XYZEPS)).OR. > ((S2.LE.-XYZEPS).AND.(S1.GE.XYZEPS)))THEN INDRSE = 1 IF(ITEST.EQ.1)GOTO 999 C ================================ C --- CALCUL DU POINT D'INTERSECTION --- C ================================ C --- L'INTERSECTION EST EN XP1 --- IF((S1.LE.XYZEPS).AND.(S1.GE.-XYZEPS ))THEN CALL COPIVE(XP1,2,XPI) GOTO 999 ENDIF C --- L'INTERSECTION EST EN XP2 --- IF((S2.LE.XYZEPS).AND.(S2.GE.-XYZEPS ))THEN CALL COPIVE(XP2,2,XPI) GOTO 999 ENDIF C --- L'INTERSECTION N'EST PAS A UNE EXTREMITE --- CALL PVDROI( DROITE, XPD, VDIR, IERR ) IF( IERR .NE. 0 )GOTO 999 CALL DIFFVE( XP1,XPD,2,V12 ) CALL DIFFVE( XPD,XP2,2,V23 ) CALL VECTVE( V12,V23,2,V2S ) X = V2S(1) / ( S1 - S2 ) IF((X.LE.XYZEPS).AND.(X.GE.-XYZEPS))THEN C --- XP1,XP2 ET XPD SONT ALIGNES --- CALL COPIVE(XPD,2,XPI) ELSE CALL MUSCVE( VDIR, -X, 2, VDIR ) CALL SOMMVE( XPD, VDIR, 2, XPI ) ENDIF C PRINT *,'INTERSECTION =',XPI(1),XPI(2) ELSE INDRSE = 0 ENDIF 999 END C SUBROUTINE DR2PO( XP1,XP2, DROITE, IERR ) C ***************************************************************** C OBJET DR2PO : CALCULE LA DROITE PASSANT PAR LES 2 POINTS 2D C EN ENTREE: C XP1, XP2 : LES 2 POINTS DE LA DROITE C EN SORTIE C DROITE : LES COEFFICIENTS A,B,C DE L'EQUATION DE LA DROITE C AX+BY+C = 0 C IERR : -1 SI XP1 ET XP2 SONT CONFONDUS, 0 SI OK C ***************************************************************** REAL XP1(2),XP2(2),DROITE(3) INTEGER IERR C COMMON /CGEPSI/ XYZHUG,XYZMIN,XYZEPS REAL XYZHUG,XYZMIN,XYZEPS REAL XDENO C IERR = 0 XDENO = XP2(1) - XP1(1) IF((XDENO.LE.XYZEPS).AND.(XDENO.GE. -XYZEPS))THEN XDENO = XP2(2) - XP1(2) IF((XDENO.LE.XYZEPS).AND.(XDENO.GE. -XYZEPS))THEN IERR = -1 GOTO 999 ENDIF DROITE(1) = 1.0 DROITE(2) = 0.0 DROITE(3) = - XP1(1) ELSE DROITE(1) = (XP1(2) - XP2(2)) / XDENO DROITE(2) = 1.0 DROITE(3) = - XP1(2) - (XP1(1) * DROITE(1)) ENDIF 999 END C C SUBROUTINE INDRDR(S1,S2,X1,X2,IDIMC,XS,INTER) C ***************************************************** C OBJET INDRDR : intersection de 2 droites C SORTIE : C INTER : < 0 une erreur C 0 pas d'intersection // ou confondus C 1 intersection C 2 confondu (a faire) C ***************************************************** REAL X1(*),X2(*),S1(*),S2(*) INTEGER IDIMC REAL XS(*) INTEGER INTER C REAL A(2),B(2),C(2),SDET,S12(2),X12(2) COMMON /CGEPSI/ XYZHUG,XYZMIN,XYZEPS,XYZHU2,XYZMI2 REAL XYZHUG,XYZMIN,XYZEPS,XYZHU2,XYZMI2 C IF(IDIMC.NE.2)THEN INTER =-3 GOTO 9999 ENDIF CALL DIFFVE(S2,S1,IDIMC,S12) CALL DIFFVE(X2,X1,IDIMC,X12) CALL VECTVE(X12,S12,IDIMC,SDET) C il faudrait normaliser !!? OS.28.06.2010 A FAIRE. ?!.. IF( ABS(SDET).LT.XYZEPS )THEN C les vecteurs sont // <=> DET=0 INTER = 0 GOTO 9999 ENDIF INTER = 1 SDET = 1.0/SDET CALL VECTVE(S12,S1,IDIMC,C(1)) CALL VECTVE(X12,X1,IDIMC,C(2)) A(1) = S12(2) A(2) = X12(2) B(1) = -S12(1) B(2) = -X12(1) CALL VECTVE(C,B,IDIMC,XS(1)) CALL VECTVE(A,C,IDIMC,XS(2)) CALL MUSCVE(XS,SDET,IDIMC,XS) 9999 END C C *************************************************************** C MODULE : CG (CALCUL GEOMETRIQUE) C FICHIER : CG_EPSI.F C OBJET : GESTION DE L'EPSILON C C FONCT. : C ICGEPS: INITIALISE LES CONSTANTES GEOMETRIQUES DU COMMON CGEPSI C C AUTEUR : O. STAB C DATE : 01.96 / 05.96 C TESTS : C MODIFICATIONS : C AUTEUR, DATE, OBJET : C C C *************************************************************** C C SUBROUTINE ICGEPS C ********************************************************************** C OBJET : INITIALISE LES CONSTANTES GEOMETRIQUES DU COMMON CGEPSI C C REMARQUE : C L'INITIALISATION DES CONSTANTES EST REALISE PAR PROCEDURE C PLUTOT QUE PAR UN BLOCK DATA POUR DES RAISONS DE PORTABILITE. C ICGEPS DOIT ETRE APPELEE AU DEBUT DE CHAQUE PROGRAMME C ********************************************************************** C C LES VALEURS : C ------------- C HUGEX : VALEUR POSITIVE MAXIMUM POUR UNE DONNEE DE TYPE X C LA VALEUR NEGATIVE MINIMUM EST -HUGEX C MINX : VALEUR POSITIVE MINIMUM POUR " " " C LA VALEUR NEGATIVE MAXIMUM EST -MINX C EPSIX : PLUS GRANDE VALEUR NEGLIGEABLE DEVANT 1 C C C LES TYPES : C ----------- C XYZ : LE TYPE COORDONNEE (REAL*4) C C LES MACHINES : C -------------- C HP700 / IRIX : C POUR LES REAL*4 C HUGEF, MINF, EPSIF = 3.402823 E+38, C 1.175495 E-38, C 1.19209290 E-07 C C POUR LES REAL*8 OU DOUBLE PRECISION C HUGED, MIND, EPSID = 1.7976931348623157E+308 , C 2.2250738585072014E-308, C 2.2204460492503131E-16 C POUR SUN / IBM : C MAXDOUBLE 1.797693134862315708E+308 C MAXFLOAT ((FLOAT)3.40282346638528860E+38) C MINDOUBLE 4.94065645841246544E-324 C MINFLOAT ((FLOAT)1.40129846432481707E-45) C COMMON /CGEPSI/ XYZHUG,XYZMIN,XYZEPS,XYZHU2,XYZMI2 C REAL XYZHUG,XYZMIN,XYZEPS,XYZHU2,XYZMI2 C XYZHUG = 3.402823E+38 XYZMIN = 1.175495E-38 XYZHU2 = 1.E+19 XYZMI2 = 1.E-19 XYZEPS = 1.19209290E-07 C END C C ***************************************************************** C MODULE : CG (CALCUL GEOMETRIQUE) C FICHIER : CG_INTER2D.F C OBJET : INTERSECTION D'UNE DROITE AVEC UN POLYGONE SIMPLE C C FONCT. : C INDRPO : INTERSECTION D'UN POLYGONE SIMPLE AVEC UNE DROITE C C AUTEUR : O. STAB C DATE : 03.95 C MODIFICATIONS : C AUTEUR, DATE, OBJET : C C C ***************************************************************** C SUBROUTINE INDRPO(X,Y,NBN,DROITE,PZERO,NBA,IARET,NBS,SOM) C ***************************************************************** C OBJET : INTERSECTION D'UN POLYGONE SIMPLE AVEC UNE DROITE C EN ENTREE : C X,Y : TABLEAU DES COORDONNEES DES POINTS DU POLYGONE C NBN : NOMBRE DE POINT DU POLYGONE C DROITE: EQUATION DE LA DROITE C PZERO : PRECISION DU CALCUL C EN SORTIE: C IARET : INDICES DES ARETES DU POLY QU'INTERSECTE DROITE C NBA : NOMBRE " " " " " C SOM : INDICES DES SOMMETS DU POLY QU'INTERSECTE DROITE C NBS : NOMBRE " " " " " C ***************************************************************** INTEGER NBN,NBA,NBS,IARET(*),SOM(*) REAL X(*),Y(*),PZERO REAL DROITE(3) C REAL S INTEGER K,K2,ISD C NBS = 0 NBA = 0 S = DROITE(1)*X(1)+DROITE(2)*Y(1)+DROITE(3) C --- TEST DU PREMIER SOMMET --- IF((S.LT.PZERO).AND.(S.GT.-PZERO))THEN NBS = NBS + 1 SOM(NBS) = 1 ISD = 0 ELSE IF( S.GT.PZERO )THEN ISD = 1 ELSE ISD = -1 ENDIF ENDIF C --- TEST DES ARETES --- DO 20 K=1,NBN K2 = MOD(K,NBN)+1 S = DROITE(1)*X(K2)+DROITE(2)*Y(K2)+DROITE(3) C --- LE SOMMET K+1 EST SUR LA DROITE --- IF((S.LT.PZERO).AND.(S.GT.-PZERO))THEN NBS = NBS + 1 SOM(NBS) = K2 ISD = 0 ELSE C --- ON ETAIT SUR LA DROITE --- IF( ISD.EQ.0 )THEN IF( S.GT.PZERO )THEN ISD = 1 ELSE ISD = -1 ENDIF ELSE C ---- ON ETAIT PAS SUR LA DROITE C ---- ET ON CHANGE DE COTE --- IF((S*ISD).LT.-PZERO)THEN ISD = -ISD NBA=NBA+1 IARET(NBA)=K ENDIF ENDIF ENDIF IF(K.NE.0)S=DROITE(1)*X(K)+DROITE(2)*Y(K)+DROITE(3) 20 CONTINUE 999 END C C ***************************************************************** C MODULE : CG (CALCUL GEOMETRIQUE) C FICHIER : CG_POLYGON.F C OBJET : CALCULS GEOMETRIQUES ELEMENTAIRES SUR LES POLYGONES C D'UN MAILLAGE C FONCT. : C G2SFPL : CALCULE LA SURFACE D'UN POLYGONE EN 2D C G2ORPL : RENVOI L'ORIENTATION D'UN POLYGONE EN 2D C C AUTEUR : O. STAB C DATE : 12.97 C TESTS : C MODIFICATIONS : C AUTEUR, DATE, OBJET : C C C ***************************************************************** C C SUBROUTINE G2SFPL(IPOINT, NBPOIN, COORD, SURFPL) C ***************************************************************** C OBJET G2SFPL : CALCULE LA SURFACE D'UN POLYGONE EN 2D C EN ENTREE : C IPOINT : INDICE DES POINTS (DANS COORD) C NBPOIN : NOMBRE DE POINTS C COORD : COORDONNEES DES NOEUDS C EN SORTIE : C SURFPL : SURFACE DU POLYGONE C REMARQUE : POSITIF POUR LE SENS TRIGO, NEGATIF POUR LE SENS INVERSE C ***************************************************************** INTEGER IPOINT(*),NBPOIN REAL COORD(*) REAL SURFPL C INTEGER I,IORIG REAL XP0,YP0,XP1,YP1,XP2,YP2,YMIN C SURFPL = 0.0 IF( NBPOIN.LE.0 ) GOTO 9999 C --- POUR PLUS DE FIABILITE ET EVITER LES OVERFLOW C ON PREND LE PREMIER POINT COMME ORIGINE DU REPERE D'INTEGRATION --- C XP0 = COORD(((IT(1)-1)*2)+1) YMIN = COORD(IPOINT(1)*2 ) IORIG = 1 DO 10 I=2,NBPOIN IF( COORD(IPOINT(I)*2 ).LT.YMIN )THEN IORIG = I YMIN = COORD(IPOINT(I)*2 ) ENDIF 10 CONTINUE XP0 = COORD(IPOINT(IORIG)*2-1) YP0 = COORD(IPOINT(IORIG)*2 ) XP2 = COORD(IPOINT(1)*2-1) - XP0 YP2 = COORD(IPOINT(1)*2 ) - YP0 DO 100 I=1,(NBPOIN-1) XP1 = XP2 YP1 = YP2 C XP2 = COORD(((IT(I+1)-1)*2+1)- XP0 XP2 = COORD(IPOINT(I+1)*2-1) - XP0 YP2 = COORD(IPOINT(I+1)*2 ) - YP0 C ---- POUR UN SEGMENT DE DROITE ---- SURFPL = SURFPL + YP2*XP2 - YP2*XP1 + YP1*XP2 - YP1*XP1 100 CONTINUE C ---- ON FERME --- XP1 = XP2 YP1 = YP2 XP2 = COORD(IPOINT(1)*2-1) - XP0 YP2 = COORD(IPOINT(1)*2 ) - YP0 SURFPL = SURFPL + YP2*XP2 - YP2*XP1 + YP1*XP2 - YP1*XP1 SURFPL = -0.5 * SURFPL 9999 END C C FUNCTION G2ORPL(IPOINT, NBPOIN, COORD, ZERO) C ***************************************************************** C OBJET G2ORPL : RENVOI L'ORIENTATION D'UN POLYGONE EN 2D C EN ENTREE : C IPOINT : INDICE DES POINTS (DANS COORD) C NBPOIN : NOMBRE DE POINTS C COORD : COORDONNEES DES NOEUDS C ZERO : SURFACE CONSIDEREE COMME NULLE C EN SORTIE : C SURFPL : SURFACE DU POLYGONE C ***************************************************************** INTEGER G2ORPL INTEGER IPOINT(*),NBPOIN REAL COORD(*),ZERO C REAL SURFPL C CALL G2SFPL(IPOINT, NBPOIN, COORD, SURFPL) IF(SURFPL.GT.ZERO)THEN G2ORPL = 1 ELSE IF(SURFPL.GT.ZERO)THEN G2ORPL = -1 ELSE G2ORPL = 0 ENDIF ENDIF 9999 END C C ***************************************************************** C MODULE : CG (CALCUL GEOMETRIQUE) C FICHIER : CG_SUITE.F C OBJET : CALCULS SUR LES SUITES C FONCT. : C C SU2PO : CALCUL DE LA SUITE ENTRE 2 POINTS C SCSUSE : CALCUL EN 2 POINTS LA VALEUR DE LA SUITE C SUPTSU : GENERE LES POINTS D'UNE SUITE C SCSUPO : VALEUR D'UNE SUITE EN UN POINT C POSUM : GENERE LES POINTS D'UNE SUITE AVEC CALAGE C POSUNM : GENERE LES POINTS D'UNE SUITE NON MONOTONE (OBSOLET) C POSUNM2 : GENERE LES POINTS D'UNE SUITE NON MONOTONE (2005) C LISUPO : REGULARISE LA POSITION D'UN POINT ENTRE 2 AUTRES C C FONCT LOCALES : C ------- PROGRESSION GEOMETRIQUE ------- C SUG2PO : CALCUL DE LA SUITE GEOMETRIQUE ENTRE 2 POINTS C SCSUGS : CALCUL EN 2 POINTS LA VALEUR DE LA SUITE GEOMETRIQUE C POSUG : GENERE LES POINTS D'UNE SUITE GEOMETRIQUE C ------- PROGRESSION ARITHMETIQUE ------- C SUA2PO : CALCUL DE LA SUITE ARITHMETIQUE ENTRE 2 POINTS C SCSUAS : CALCUL EN 2 POINTS LA VALEUR DE LA SUITE ARITHMETIQUE C POSUA : GENERE LES POINTS D'UNE SUITE ARITHMETIQUE C C AUTEUR : O. STAB C DATE : 03.95 / 06.95 C TESTS : 07.95 C MODIFICATIONS : C AUTEUR, DATE, OBJET : STAB, 02.09.98, BUG NUMERIQUE DANS SUG2PO C AUTEUR, DATE, OBJET : STAB, 31.01.05, ajout POSUNM2 (remplace POSUNM) C AUTEUR, DATE, OBJET : STAB, 18.08.06 : SUG2PO C erreur de FORMULE dans le calcul de la suite !!!!!!!!! C R = ( XD - X0 ) / ( XD - XN ) C AUTEUR, DATE, OBJET : STAB, 07.09.06 : SCSUPO C calcul de la taille discrete (paliers) pour C les suites geometriques plutot que lineaire !!! C ***************************************************************** C C ========================= C ---------------------- PROGRESSION GEOMETRIQUE ------------------ C ========================= C SUBROUTINE SUG2PO(XD,X0,XN,N,R,IERR) C ***************************************************************** C OBJET SUG2PO: CALCUL DE LA SUITE GEOMETRIQUE ENTRE 2 POINTS (LOCAL) C EN ENTREE : C XD : LA LONGUEUR DU SEGMENT C X0 : LA TAILLE SOUHAITE A L'ORIGINE C XN : LA TAILLE SOUHAITE A L'EXTREMITE C EN SORTIE : C R : LA RAISON DE LA SUITE GEOMETRIQUE C N : LE NOMBRE DE NOEUDS C IERR: -1 SI ERREUR DANS LES DONNEES D'ENTREE C ***************************************************************** REAL XD,X0,XN INTEGER N,IERR REAL R C COMMON /CGEPSI/ XYZHUG,XYZMIN,XYZEPS REAL XYZHUG,XYZMIN,XYZEPS REAL XNBN C IERR = 0 C IF((XN.LE.XYZEPS).OR.(X0.LE.XYZEPS))THEN C MODIF 980902 : IF((XN.LE.XYZMIN).OR.(X0.LE.XYZMIN))THEN IERR = -1 CALL DSERRE(1,IERR,'CG', > 'DANS SUG2PO : TAILLE SOUHAITEE NEGATIVE OU NULLE') GO TO 999 ENDIF IF(XD.LT.XYZMIN)THEN R = 1. N = 0 GO TO 999 ENDIF C C IF( ABS(X0 - XN) .LE. (X0+XN)*ZERO )THEN C IF( ABS((LOG(XD + XN)-LOG(XD + X0))).LE.XYZMIN )THEN C BUG NUMERIQUE 980902 : le log applati TROP l'erreur C C R = ( XD + XN ) / ( XD + X0 ) C BUG 18.08.06 : erreur de FORMULE dans le calcul de la suite !!!!!!!!! IF( XN.EQ.XD )THEN N=0 R=1. GOTO 999 ENDIF R = ( XD - X0 ) / ( XD - XN ) IF( (ABS( R - 1.) .LE. XYZEPS ).OR. > (ABS(X0 - XN) .LE. (X0+XN)*XYZEPS ) )THEN XNBN = (2. * XD / (X0 + XN) ) - 1. ELSE C XNBN = ((LOG(XN) - LOG(X0)) / (LOG(XD + XN)-LOG(XD + X0))) C > - 2. C MODIF 980902 : C XNBN = LOG(XN / X0) / LOG((XD + XN)/(XD + X0)) - 2. C XNBN = LOG(XN / X0) / LOG(R) - 2. C BUG 18.08.06 : erreur de FORMULE dans le calcul de la suite !!!!!!!!! XNBN = LOG(XN / X0) / LOG(R) ENDIF C PRINT *,'ERREUR DE TRONCATURE :',N,XNBN C N = NINT(XNBN) C MODIF 18.08.06 => NON N = NINT(XNBN) C 999 END C SUBROUTINE SCSUGS(XD,N,R,X0,XN,IERR) C ***************************************************************** C OBJET SCSUGS : CALCUL EN 2 POINTS LA VALEUR DE LA SUITE GEOMETRIQUE (LOCAL) C EN ENTREE : C XD : LA LONGUEUR DU SEGMENT C R : LA RAISON DE LA SUITE GEOMETRIQUE C N : LE NOMBRE DE NOEUDS C EN SORTIE : C X0 : LA TAILLE SOUHAITE A L'ORIGINE C XN : LA TAILLE SOUHAITE A L'EXTREMITE C IERR: -1 SI ERREUR DANS LES DONNEES D'ENTREE C ***************************************************************** REAL XD,X0,XN INTEGER N,IERR REAL R C COMMON /CGEPSI/ XYZHUG,XYZMIN,XYZEPS REAL XYZHUG,XYZMIN,XYZEPS C IERR = 0 IF(R.LE.XYZEPS)THEN IERR = -1 CALL DSERRE(1,IERR,'CG', > 'DANS SCSUGS : RAISON NEGATIVE OU NULLE') GO TO 999 ENDIF IF(XD.LE.XYZEPS)THEN IERR = -1 CALL DSERRE(1,IERR,'CG', > 'DANS SCSUGS : LONGUEUR DU SEGMENT NEGATIVE OU NULLE') GO TO 999 ENDIF IF(N.LE.0)THEN IERR = -1 CALL DSERRE(1,IERR,'CG', > 'DANS SCSUGS : NOMBRE DE NOEUDS NEGATIF OU NUL') GO TO 999 ENDIF C IF( ABS(1.-R) .LE. XYZEPS )THEN X0 = XD / (N + 1) XN = X0 ELSE X0 = XD * (1-R) / (R * (1-R**(N+1))) C PRINT *,' D = ', XD C PRINT *,' D = ', (X0 * R * (1-R**(N+1))/(1-R)) C PRINT *,' - ', XD - (X0 * R * (1-R**(N+1))/(1-R)) XN = R**(N+2) * X0 ENDIF C 999 END C SUBROUTINE POSUG(X1,V1,IDIMC,T,N,R,XYZPT,IERR) C ***************************************************************** C OBJET POSUG : GENERE LES POINTS D'UNE SUITE GEOMETRIQUE (LOCAL) C EN ENTREE : C X1 : LE POINT ORIGINE C V1 : LE VECTEUR X2-X1 C IDIMC : LA DIMENSION DE L'ESPACE C T : VALEUR INITIALE DE LA SUITE (EN X1) C N : NOMBRE DE SEGMENT APRES DECOUPAGE C SI N = 1 ALORS XYZPT() = X1 + V1 C R : RAISON DE LA SUITE GEOMETRIQUE C EN SORTIE : C XYZPT : COORDONNEES DES POINTS CALCULES C IERR : -1 SI ERREUR DANS LES DONNEES D'ENTREE C ***************************************************************** REAL X1(*),V1(*),T,R,XYZPT(*) INTEGER IDIMC,N,IERR C INTEGER I,J REAL RI C COMMON /CGEPSI/ XYZHUG,XYZMIN,XYZEPS REAL XYZHUG,XYZMIN,XYZEPS REAL COEF C IF( N.LE.0 )THEN IERR = -1 CALL DSERRE(1,IERR,'CG', > 'DANS POSUG : NOMBRE DE NOEUDS NEGATIF OU NUL') GO TO 999 ENDIF IERR = 0 C IF(((1.-R).LE.XYZEPS).AND.((1.-R).GE.-XYZEPS))THEN DO 20 I=1,N COEF = I * T DO 10 J=1,IDIMC XYZPT((I-1)*IDIMC+J) = X1(J) + COEF * V1(J) 10 CONTINUE 20 CONTINUE ELSE RI = 1.0 DO 50 I=1,N RI = RI * R COEF = R * T * (1-RI) / (1-R) DO 40 J=1,IDIMC XYZPT((I-1)*IDIMC+J) = X1(J) + COEF * V1(J) 40 CONTINUE 50 CONTINUE ENDIF C 999 END C ========================== C ---------------------- PROGRESSION ARITHMETIQUE ----------------- C ========================== C SUBROUTINE SUA2PO(XD,X0,XN,N,R,IERR) C ***************************************************************** C OBJET SUA2PO : CALCUL DE LA SUITE ARITHMETIQUE ENTRE 2 POINTS (LOCAL) C EN ENTREE : C XD : LA LONGUEUR DU SEGMENT C X0 : LA TAILLE SOUHAITE A L'ORIGINE C XN : LA TAILLE SOUHAITE A L'EXTREMITE C EN SORTIE : C R : LA RAISON DE LA SUITE ARITHMETIQUE C N : LE NOMBRE DE NOEUDS C IERR: -1 SI ERREUR DANS LES DONNEES D'ENTREE C ***************************************************************** REAL XD,X0,XN INTEGER N,IERR REAL R C COMMON /CGEPSI/ XYZHUG,XYZMIN,XYZEPS REAL XYZHUG,XYZMIN,XYZEPS REAL XNBN C IERR = 0 IF((XN.LE.XYZEPS).OR.(X0.LE.XYZEPS))THEN IERR = -1 CALL DSERRE(1,IERR,'CG', > 'DANS SUG2PO : TAILLE SOUHAITEE NEGATIVE OU NULLE') GO TO 999 ENDIF IF(XD.LT.XYZMIN)THEN R = 1. N = 0 GO TO 999 ENDIF C XNBN = (2. * XD / (X0 + XN) ) - 1. N = NINT(XNBN) R = 2. * XD * ( XN - X0 ) / ((N+1)*(N+2)*(XN + X0)) C PRINT *,'ERREUR DE TRONCATURE :',N,XNBN C 999 END C SUBROUTINE SCSUAS(XD,N,R,X0,XN,IERR) C ***************************************************************** C OBJET SCSUAS : CALCUL EN 2 POINTS LA VALEUR DE LA SUITE ARITHMETIQUE (LOCAL) C EN ENTREE : C XD : LA LONGUEUR DU SEGMENT C R : LA RAISON DE LA SUITE ARITHMETIQUE C N : LE NOMBRE DE NOEUDS C EN SORTIE : C X0 : LA TAILLE SOUHAITE A L'ORIGINE C XN : LA TAILLE SOUHAITE A L'EXTREMITE C IERR: -1 SI ERREUR DANS LES DONNEES D'ENTREE C ***************************************************************** REAL XD,X0,XN INTEGER N,IERR REAL R C IERR = 0 IF(N.LE.0)THEN IERR = -1 GO TO 999 ENDIF C C PRINT *,' XD = ',XD,' = ',((N+1)*(X0+R*(N+2)/2)) X0 = (XD/(N+1)) - R*(N+2)/2 XN = X0 + (N+2)*R C 999 END C SUBROUTINE POSUA(X1,V1,IDIMC,T,N,R,XYZPT,IERR) C ***************************************************************** C OBJET POSUA : GENERE LES POINTS D'UNE SUITE ARITHMETIQUE (LOCAL) C EN ENTREE : C X1 : LE POINT ORIGINE C V1 : LE VECTEUR X2-X1 C IDIMC : LA DIMENSION DE L'ESPACE C T : VALEUR INITIALE DE LA SUITE (EN X1) C N : NOMBRE DE SEGMENT APRES DECOUPAGE C SI N = 1 ALORS XYZPT() = X1 + V1 C R : RAISON DE LA SUITE ARITHMETIQUE C EN SORTIE : C XYZPT : COORDONNEES DES POINTS CALCULES C IERR : -1 SI ERREUR DANS LES DONNEES D'ENTREE C ***************************************************************** REAL X1(*),V1(*),T,R,XYZPT(*) INTEGER IDIMC,N,IERR C INTEGER I,J REAL COEF C IF( N.LE.0 )THEN IERR = -1 GO TO 999 ENDIF IERR = 0 C DO 20 I=1,N COEF = I * (T + ((I+1) * R) / 2.) DO 10 J=1,IDIMC XYZPT((I-1)*IDIMC+J) = X1(J) + COEF * V1(J) 10 CONTINUE 20 CONTINUE C 999 END C ========================== C ---------------------- PROGRESSION (CAS GENERAL) ---------------- C ========================== C C SUBROUTINE SCSUSE(ITYPE,XD,N,R,X0,XN,IERR) C ***************************************************************** C OBJET SCSUSE : CALCUL EN 2 POINTS LA VALEUR DE LA SUITE C EN ENTREE : C ITYPE : TYPE DE LA SUITE C (1=GEOMETRIQUE,2=ARITHMETIQUE,3=HARMONIQUE) C XD : LA LONGUEUR DU SEGMENT C R : LA RAISON DE LA SUITE GEOMETRIQUE C N : LE NOMBRE DE NOEUDS C EN SORTIE : C X0 : LA TAILLE SOUHAITE A L'ORIGINE C XN : LA TAILLE SOUHAITE A L'EXTREMITE C IERR: -1 SI ERREUR DANS LES DONNEES D'ENTREE C ***************************************************************** INTEGER ITYPE REAL XD,X0,XN INTEGER N,IERR REAL R C GOTO (10,20,30) ITYPE IERR = -1 GO TO 999 C --- SUITE GEOMETRIQUE ------------ 10 CALL SCSUGS(XD,N,R,X0,XN,IERR) GO TO 999 C --- SUITE ARITHMETIQUE ----------- 20 CALL SCSUAS(XD,N,R,X0,XN,IERR) GO TO 999 C --- SUITE HARMONIQUE ------------- 30 IERR = -4 C PRINT *, ' A FAIRE ' GO TO 999 999 END C SUBROUTINE SU2PO(ITYPE,XD,X0,XN,N,R,IERR) C ***************************************************************** C OBJET SU2PO : CALCUL DE LA SUITE ENTRE 2 POINTS C EN ENTREE : C ITYPE : TYPE DE LA SUITE C (1=GEOMETRIQUE,2=ARITHMETIQUE,3=HARMONIQUE) C XD : LA LONGUEUR DU SEGMENT C X0 : LA TAILLE SOUHAITE A L'ORIGINE C XN : LA TAILLE SOUHAITE A L'EXTREMITE C EN SORTIE : C R : LA RAISON DE LA SUITE GEOMETRIQUE C N : LE NOMBRE DE NOEUDS C IERR: -1 SI ERREUR DANS LES DONNEES D'ENTREE C ***************************************************************** INTEGER ITYPE REAL XD,X0,XN INTEGER N,IERR REAL R C GOTO (10,20,30) ITYPE IERR = -1 GO TO 999 C --- SUITE GEOMETRIQUE ------------ 10 CALL SUG2PO(XD,X0,XN,N,R,IERR) GO TO 999 C --- SUITE ARITHMETIQUE ----------- 20 CALL SUA2PO(XD,X0,XN,N,R,IERR) GO TO 999 C --- SUITE HARMONIQUE ------------- 30 IERR = -4 C PRINT *, ' A FAIRE ' GO TO 999 999 END C C SUBROUTINE SUPTSU(X1,V1,IDIMC,ITYPE,T,N,R,XYZPT,IERR) C ***************************************************************** C OBJET SUPTSU : GENERE LES POINTS D'UNE SUITE C EN ENTREE : C X1 : LE POINT ORIGINE C V1 : LE VECTEUR DIRECT C IDIMC : LA DIMENSION DE L'ESPACE C T : VALEUR INITIALE C N : NOMBRE DE SEGMENT APRES DECOUPAGE C SI N = 1 ALORS XYZPT() = X1 + V1 C R : RAISON DE LA SUITE GEOMETRIQUE C EN SORTIE : C XYZPT : COORDONNEES DES POINTS CALCULES C IERR : -1 SI ERREUR DANS LES DONNEES D'ENTREE C ***************************************************************** REAL X1(*),V1(*),R,T,XYZPT(*) INTEGER ITYPE,IDIMC,N,IERR C GOTO (10,20,30) ITYPE IERR = -1 GO TO 999 C --- SUITE GEOMETRIQUE ------------ 10 CALL POSUG(X1,V1,IDIMC,T,N,R,XYZPT,IERR) GO TO 999 C --- SUITE ARITHMETIQUE ----------- 20 CALL POSUA(X1,V1,IDIMC,T,N,R,XYZPT,IERR) GO TO 999 C --- SUITE HARMONIQUE ------------- 30 IERR = -4 C PRINT *, ' A FAIRE ' GO TO 999 999 END C C SUBROUTINE SCSUPO(ITYPE,TSP,RSG,D,VSD) C ***************************************************************** C OBJET SCSUPO : VALEUR D'UNE SUITE EN UN POINT C EN ENTREE : C ITYPE : TYPE DE LA SUITE C (1=GEOMETRIQUE,2=ARITHMETIQUE,3=HARMONIQUE) C TSP : LA TAILLE SOUHAITE AU POINT C RSG : RAISON DE LA SUITE GEOMETRIQUE C D : ABCISSE OU ON CHERCHE LA VALEUR DE LA SUITE C EN SORTIE : C VSD : LA VALEUR DE LA SUITE A L'ABCISSE D C ***************************************************************** INTEGER ITYPE REAL D,TSP,RSG,VSD C COMMON /CGEPSI/ XYZHUG,XYZMIN,XYZEPS REAL XYZHUG,XYZMIN,XYZEPS INTEGER N REAL VSC,A GOTO (10,20,30) ITYPE VSD = 0.0 GO TO 999 C --- SUITE GEOMETRIQUE ------------ C D'OU CA SORT ? 10 VSD = (D*(RSG-1.)+TSP) / RSG C 10 VSD = TSP - D*(1.- RSG) 10 VSC = TSP + D*(RSG -1.) C remplace le 07.09.2006 par OS : IF( RSG.EQ.1 )THEN VSD = TSP ELSE A= (D/TSP)*(RSG-1)+1 N = ( (LOG((D/TSP)*(RSG-1)+1)/LOG(RSG)) -XYZEPS) VSD = TSP * RSG**N C write (*,*) 'VSD= ',VSD,' VSC= ',VSC ENDIF GO TO 999 C --- SUITE ARITHMETIQUE ----------- 20 VSD = RSG**2 + (8. * D + 4. * TSP)*RSG + 4.*TSP**2 IF( VSD .LT. 0.0 )GOTO 999 VSD = (RSG + SQRT( VSD ))/2. C PRINT *, ' VSD ',VSD GO TO 999 C --- SUITE HARMONIQUE ------------- 30 VSD = 0.0 C PRINT *, ' A FAIRE ' GO TO 999 999 END C C SUBROUTINE POSUM(XP1,XP2,IDIMC,TS1,TS2,ITYPS, > XPI,NPIMAX,NBPI,IERR) C ***************************************************************** C OBJET POSUM : GENERE LES POINTS D'UNE SUITE AVEC CALAGE C EN ENTREE : C XP1 : LE POINT ORIGINE C XP2 : LE POINT EXTREMITE C IDIMC : LA DIMENSION DE L'ESPACE C TS1 : TAILLE SOUHAITE EN XP1 C TS2 : TAILLE SOUHAITE EN XP2 C ITYPS : TYPE DE LA SUITE C NPIMAX : NOMBRE MAXIMUM DE POINTS GENERES C EN SORTIE : C XPI : COORDONNEES DES POINTS CALCULES C NBPI : NOMBRE DE POINTS GENERES C TS1 : TAILLE REALISE EN XP1 C TS2 : TAILLE REALISE EN XP2 C IERR : 0 SI OK C -1 SI ERREUR DANS LES DONNEES D'ENTREE C -2 SI XYZPT TROP PETIT C ***************************************************************** REAL XP1(*),XP2(*),TS1,TS2,XPI(*) INTEGER ITYPS,NBPI,NPIMAX,IDIMC,IERR C REAL RSGCAL,V1(3),S12 REAL XNORVE C INTEGER ITRACE EXTERNAL DIFFVE,DIPOOB,XNORVE EXTERNAL SU2PO,SUPTSU C IERR = 0 C --- CALCUL DE LA SUITE ------------------------------------ CALL DIFFVE(XP2,XP1,IDIMC,V1) S12 = XNORVE(V1,IDIMC) CALL SU2PO(ITYPS,S12,TS1,TS2,NBPI,RSGCAL,IERR) IF( IERR .NE. 0 )GOTO 888 IF( NBPI .LE. 0 )THEN NBPI = 0 GOTO 999 ENDIF C --- RECALALGE DES VALEURS TS1, TS2 --- CALL SCSUSE(ITYPS,S12,NBPI,RSGCAL,TS1,TS2,IERR) IF( IERR .NE. 0 )GOTO 888 C C --- POUR LE DEBUG : C C ITRACE = 0 C IF(ITRACE.NE.0)PRINT *,'(T1,T2,NB,R)',TS1,TS2,NBPI,RSGCAL C CALL DEBSUSYM(ITYPS,S12,TS1,TS2,ITRACE,0.0,IERR) C IF( IERR.NE. 0 )THEN C PRINT *,'ERREUR DANS DEDSUSYM' C GOTO 999 C ENDIF C --- FIN DEBUG ----- C IF( NBPI .GT. NPIMAX )THEN IERR = -2 CALL DSERRE(1,IERR,'CG','DANS POSUM : TROP DE POINTS') GO TO 999 ENDIF S12 = 1 / S12 CALL MUSCVE(V1,S12,IDIMC,V1) CALL SUPTSU(XP1,V1,IDIMC,ITYPS,TS1,NBPI,RSGCAL,XPI,IERR) C 888 IF( IERR .NE. 0 )CALL DSERRE(1,IERR,'CG','DANS POSUM') 999 END C SUBROUTINE POSUNM(XP1,XPNUL,XP2,IDIMC,TS1,TSNUL,TS2,ITYPS, > XPI,NPIMAX,NBPI,IERR) C ***************************************************************** C OBJET POSUNM : GENERE LES POINTS D'UNE SUITE NON MONOTONE C AVEC CALAGE C EN ENTREE : C XP1 : LE POINT ORIGINE C XPNUL : UN POINT SUR LE SEGMENT C XP2 : LE POINT EXTREMITE C IDIMC : LA DIMENSION DE L'ESPACE C TS1 : TAILLE SOUHAITE EN XP1 C TSNUL : TAILLE SOUHAITE EN XPNUL C TS2 : TAILLE SOUHAITE EN XP2 C ITYPS : TYPE DE LA SUITE C NPIMAX : NOMBRE MAXIMUM DE POINTS GENERES C EN SORTIE : C XPI : COORDONNEES DES POINTS CALCULES C NBPI : NOMBRE DE POINTS GENERES C TS1 : TAILLE REALISE EN XP1 C TSNUL : TAILLE REALISE EN XPNUL C TS2 : TAILLE REALISE EN XP2 C IERR : 0 SI OK C -1 SI ERREUR DANS LES DONNEES D'ENTREE C -2 SI XYZPT TROP PETIT C ***************************************************************** REAL XP1(*),XPNUL(*),XP2(*),TS1,TSNUL,TS2,XPI(*) INTEGER ITYPS,NBPI,NPIMAX,IDIMC,IERR C REAL RSGCAL,V1(3),S12,S22,TSNUL2 INTEGER NBPI1,NBPI2,NIMAX2 REAL XNORVE EXTERNAL DIFFVE,XNORVE EXTERNAL SU2PO,SUPTSU C C IERR = 0 C ---------------------------------- C --- CALCUL DE LA SUITE SUR XP1, XPNUL --------- C ---------------------------------- CALL DIFFVE(XPNUL,XP1,IDIMC,V1) S12 = XNORVE(V1,IDIMC) C WRITE(*,*) 'S12 = ',S12 CALL SU2PO(ITYPS,S12,TSNUL,TS1,NBPI1,RSGCAL,IERR) IF( IERR .NE. 0 )GOTO 888 C ---------------------------------- C --- CALCUL DE LA SUITE SUR XPNUL, XP2 --------- C ---------------------------------- CALL DIFFVE(XP2,XPNUL,IDIMC,V1) S22 = XNORVE(V1,IDIMC) C WRITE(*,*) 'S22 = ',S22 CALL SU2PO(ITYPS,S22,TS1,TSNUL,NBPI2,RSGCAL,IERR) C ---- ???? ERREUR : TSNUL,TS2, C IF( IERR .NE. 0 )GOTO 888 IF(( NBPI1 .GE. 0 ).AND.( NBPI2 .GE. 0 ))THEN C ------------------------------------- C --- ON DECOUPE LE SEGMENT EN 2 INTERVALS --- C ------------------------------------- IF( (NBPI1+NBPI2+1) .GT. NPIMAX )THEN IERR = -2 CALL DSERRE(1,IERR,'CG','DANS POSUNM : TROP DE POINTS') GO TO 999 ENDIF C --- PREMIER INTERVAL --- NBPI = 0 TSNUL2 = TSNUL CALL POSUM(XP1,XPNUL,IDIMC,TS1,TSNUL2,ITYPS, > XPI,NPIMAX,NBPI,IERR) IF( IERR .NE. 0 )GOTO 888 C --- BUG 7 ---- C NE COPIER XPNUL QUE SI XP1-XPNUL ET XP2-XPNUL C SONT COMPATIBLE AVEC TSNUL C IF(( S12.GE. TSNUL ).AND.( S22.GE.TSNUL ))THEN NBPI1 = NBPI+1 CALL COPIVE(XPNUL,IDIMC,XPI((NBPI1-1)*IDIMC+1)) ENDIF C C --- DEUXIEME INTERVAL --- NBPI = 0 NIMAX2 = NPIMAX - NBPI1 CALL POSUM(XPNUL,XP2,IDIMC,TSNUL,TS2,ITYPS, > XPI(NBPI1*IDIMC+1),NIMAX2,NBPI,IERR) NBPI = NBPI + NBPI1 ELSE IF(( NBPI1.LT. 0 ).AND.( NBPI2.LT. 0 ))THEN C --------------------------- C --- L'INTERVAL EST TROP PETIT --- C --------------------------- NBPI = 0 ELSE C ------------------------------------ C --- XP1 OU XP2 EST CONFONDU AVEC XPNUL --- C ------------------------------------ CALL POSUM(XP1,XP2,IDIMC,TS1,TS2,ITYPS, > XPI,NPIMAX,NBPI,IERR) ENDIF ENDIF C 888 IF( IERR .NE. 0 )CALL DSERRE(1,IERR,'CG','DANS POSUNM') 999 END C C C SUBROUTINE POSUNM2(XP1,XPNUL,NBX,XP2,IDIMC,TS1,TSNUL,TS2,ITYPS, > XPI,NPIMAX,NBPI,IERR) C ***************************************************************** C OBJET POSUNM2 : GENERE LES POINTS D'UNE SUITE NON MONOTONE C AVEC CALAGE C EN ENTREE : C XP1 : LE POINT ORIGINE C XPNUL(NBX*IDIMC) : COORDONNEES DES NBX POINTS SUR LE SEGMENT C XP2 : LE POINT EXTREMITE C IDIMC : LA DIMENSION DE L'ESPACE C TS1 : TAILLE SOUHAITE EN XP1 C TSNUL : TAILLE SOUHAITE AUX POINTS DE XPNUL C TS2 : TAILLE SOUHAITE EN XP2 C ITYPS : TYPE DE LA SUITE C NPIMAX : NOMBRE MAXIMUM DE POINTS GENERES C C EN SORTIE : C XPI : COORDONNEES DES POINTS CALCULES C NBPI : NOMBRE DE POINTS GENERES C TS1 : TAILLE REALISE EN XP1 C TSNUL : TAILLE REALISE AUX POINTS DE XPNUL C TS2 : TAILLE REALISE EN XP2 C IERR : 0 SI OK C -1 SI ERREUR DANS LES DONNEES D'ENTREE C -2 SI XYZPT TROP PETIT C ***************************************************************** REAL XP1(*),XPNUL(*),XP2(*),TS1,TSNUL(*),TS2,XPI(*) INTEGER NBX,ITYPS,NBPI,NPIMAX,IDIMC,IERR C REAL RSGCAL,V1(3),V2(3),XV1,XV2,S12,S22 REAL XPS(3*6),TSXPS(6) INTEGER NBS,I,J,II INTEGER NBPI1,NBPI2,NIMAX2 REAL XNORVE,SCALVE EXTERNAL XNORVE,SCALVE C COMMON /CGEPSI/ XYZHUG,XYZMIN,XYZEPS,XYZHU2,XYZMI2 REAL XYZHUG,XYZMIN,XYZEPS,XYZHU2,XYZMI2 C IERR = 0 C ---- 1. decoupage du segment XP1,XP2 par les XPNUL ---- C ----------------------------------------------- CALL COPIVE(XP1,IDIMC,XPS) CALL COPIVE(XP2,IDIMC,XPS(IDIMC+1)) TSXPS(1) = TS1 TSXPS(2) = TS2 NBS = 2 C --- on ajoute les points sur le segment XP1,XP2 DO 100 I=1,NBX J=1 10 CONTINUE C --- situer XPNUL sur le segment CALL DIFFVE(XPNUL((I-1)*IDIMC+1),XPS((J-1)*IDIMC+1),IDIMC,V1) CALL DIFFVE(XPS(J*IDIMC+1) ,XPS((J-1)*IDIMC+1),IDIMC,V2) XV1 = SCALVE(V2,V1,IDIMC) XV2 = SCALVE(V2,V2,IDIMC) IF(XV1.LT.-XYZEPS*XV2)GOTO 901 IF( XV1.GT.XV2*(1.+XYZEPS) )THEN J=J+1 IF(J.LT.NBS)GOTO 10 ENDIF IF(J.GT.NBS)GOTO 901 C --- XPS(J) < XPNUL(I) < XPS(J+1) --- S12 = XNORVE(V1,IDIMC) CALL SU2PO(ITYPS,S12,TSNUL(I),TSXPS(J),NBPI1,RSGCAL,IERR) IF( IERR .NE. 0 )GOTO 902 CALL DIFFVE(XPS(J*IDIMC+1),XPNUL((I-1)*IDIMC+1),IDIMC,V1) S22 = XNORVE(V1,IDIMC) CALL SU2PO(ITYPS,S22,TSXPS(J+1),TSNUL(I),NBPI2,RSGCAL,IERR) IF( IERR .NE. 0 )GOTO 902 IF(( NBPI1 .GT. 0 ).AND.( NBPI2 .GT. 0 ))THEN C --- on ajoute XPNUL au decoupage du segment DO 50 II=NBS,J+1,-1 CALL COPIVE(XPS((II-1)*IDIMC+1),IDIMC,XPS(II*IDIMC+1)) TSXPS(II+1) = TSXPS(II) 50 CONTINUE CALL COPIVE(XPNUL((I-1)*IDIMC+1),IDIMC,XPS(J*IDIMC+1)) TSXPS(J+1) = TSNUL(I) NBS=NBS+1 ENDIF 100 CONTINUE C C ---- 2. generation des points sur les segments ---- C ----------------------------------------------- C WRITE (*,*) 'segment : ',(XP1(II),II=1,IDIMC),' a ', C > (XP2(II),II=1,IDIMC) NBPI = 0 DO 200 J=1,NBS-1 C WRITE (*,*) 'intervalle : ',J,' ',(XPS(J*IDIMC+II),II=1,IDIMC) NIMAX2 = NPIMAX - NBPI NBPI1 = 0 CALL POSUM(XPS((J-1)*IDIMC+1),XPS(J*IDIMC+1),IDIMC, > TSXPS(J), TSXPS(J+1), ITYPS, > XPI(NBPI*IDIMC+1),NIMAX2,NBPI1,IERR) IF( IERR.NE.0 )GOTO 903 NBPI = NBPI + NBPI1 IF(J.NE.NBS-1)THEN NBPI = NBPI+1 CALL COPIVE(XPS(J*IDIMC+1),IDIMC,XPI((NBPI-1)*IDIMC+1)) ENDIF 200 CONTINUE C GOTO 9999 901 CONTINUE IERR = -1 CALL DSERRE(1,IERR,'POSUNM2','POINT XPNUL HORS SEGMENT') GO TO 9999 902 CONTINUE IERR = -1 CALL DSERRE(1,IERR,'POSUNM2','APPEL SU2PO ?') GO TO 9999 903 CONTINUE IERR = -1 CALL DSERRE(1,IERR,'POSUNM2','APPEL POSUM') GO TO 9999 C 9999 END C C C SUBROUTINE LISUPO(XP1,XP2,XP3,IDIMC,ITYPS,RSG,XP2N,DEPLAC,IERR) C ***************************************************************** C OBJET LISUPO : REGULARISE LA POSITION DE XP2 ENTRE XP1 ET XP3 C EN ENTREE : C XP2 : LA POSITION A REGULARISER C XP1,XP3 : L'INTERVAL CONTENANT XP2 C IDIMC : DIMENSION DE L'ESPACE C ITYPS : TYPE DE LA SUITE C RSG : RAISON DE LA SUITE C EN SORTIE : C XP2N : NOUVELLE POSITION DE XP2 C DEPLAC : NORME DU DEPLACEMENT RELATIF C IERR : -1 SI ERREUR 0 SI OK C ***************************************************************** INTEGER IDIMC,ITYPS,IERR REAL XP1(*),XP2(*),XP3(*),RSG REAL XP2N(*),DEPLAC C REAL V(3),D,D12,D23,COEF, XNORVE,ZERO PARAMETER (ZERO = 1.E-10) EXTERNAL XNORVE C IERR = 0 IF( RSG .LE. ZERO )THEN IERR = -1 CALL DSERRE(1,IERR,'LISUPO','RAISON NEGATIVE OU NULLE') GOTO 9999 ENDIF DEPLAC = 0.0 CALL COPIVE(XP2,IDIMC,XP2N) CALL DIFFVE(XP2,XP1,IDIMC,V ) D12 = XNORVE(V,IDIMC) CALL DIFFVE(XP3,XP2,IDIMC,V ) D23 = XNORVE(V,IDIMC) IF( D23 .LE. ZERO )THEN IERR = -1 CALL DSERRE(1,IERR,'LISUPO','SEGMENT NUL') GOTO 9999 ENDIF D = 1. / D23 CALL MUSCVE(V,D,IDIMC, V) GOTO(10,20) ITYPS IERR = -1 CALL DSERRE(1,IERR,'LISUPO','TYPE DE SUITE INCONNU') GOTO 9999 C --- SUITE GEOMETRIQUE --- 10 IF(((D12/D23).LT.RSG).AND.((D23/D12).LT.RSG))GOTO 9999 IF( D12.GT.D23 )THEN COEF = ( RSG*D23 - D12 ) / ( RSG + 1.0 ) ELSE COEF = ( -RSG*D12 + D23 ) / ( RSG + 1.0 ) ENDIF GOTO 30 C --- SUITE ARITHMETIQUE --- 20 IF(((D12-D23).LT.RSG).AND.((D23-D12).LT.RSG))GOTO 9999 COEF = ( RSG + D23 - D12 ) * 0.5 GOTO 30 C 30 CALL MUSCVE(V,COEF,IDIMC,V) CALL SOMMVE(XP2,V,IDIMC,XP2N) DEPLAC = 2. * COEF / (D12 + D23) IF( DEPLAC .LT. 0.0 )DEPLAC = -DEPLAC C PRINT *,' DEPLACEMENT RELATIF =',DEPLAC C 9999 END C C ***************************************************************** C MODULE : CG (CALCUL GEOMETRIQUE) C FICHIER : CG_TRIANGLE.F C OBJET : CALCUL DE LA QUALITE D'UN TRIANGLE 2D C FONCT. : C OBJET TRRIL : RENVOI RI / L DU TRIANGLE 2D C OBJET TRLL : CALCUL L'ARETE MIN. ET L'ARETE MAX. DU TRIANGLE 2D C OBJET TRLL2 : CALCUL L'ARETE MIN. ET L'ARETE MAX. DU TRIANGLE C OBJET TRLSL2 : RAPPORT MIN/MAX DES LONGUEURS DES ARETES C OBJET TRLAG2 : SINUS MINIMUM DES ANGLES DU TRIANGLE C OBJET TRLRC2 : LMAX / RAYON DU CERCLE CIRC. AU TRIANGLE C OBJET TRSURF : RENVOI LA SURFACE DU TRIANGLE C OBJET TRNORM : RENVOI LA NORMALE ET LA SURFACE DU TRIANGLE C OBJET TRRIL2 : RENVOI RI / L DU TRIANGLE C OBJET TRAGSO : RENVOI L'ANGLE AU SOMMET D'UN TRIANGLE C C AUTEUR : O. STAB C DATE : 03.95 C MODIFICATIONS : C AUTEUR, DATE, OBJET : STAB, 12.97, DE NOMBREUX AJOUTS C AUTEUR, DATE, OBJET : STAB, 02.03, AJOUTS AGSICO,TRAGSO C C ***************************************************************** C SUBROUTINE AGSICO(VASIN,VACOS,ANGLE) C ***************************************************************** C OBJET AGSICO : RENVOI LA VALEUR DE L'ANGLE (EN DEGREES [0.360]) C ATTENTION : PAS D'ORIENTATION = FABS(ANGLE) C ***************************************************************** REAL VASIN,VACOS REAL ANGLE C REAL VAPI,RAD2DG C VAPI = 3.14159265 RAD2DG = 180.0 / VAPI C ---- ASIN -> [-Pi/2,Pi/2] ---- ANGLE = ASIN( VASIN ) IF( VACOS.LT.0.0)ANGLE = VAPI - ANGLE ANGLE = ANGLE * RAD2DG IF( ANGLE.LT.0 ) ANGLE = -ANGLE 9999 END C FUNCTION TRAGSO(XP1,XP2,XP3,IDIMC) C ***************************************************************** C OBJET TRAGSO : RENVOI L'ANGLE AU SOMMET D'UN TRIANGLE C L'ANGLE ENTRE LES ARETES XP1XP2-XP1XP3 C C EN ENTREE : XP1, XP2, XP3 : LES COORDONNEES DES 3 POINTS C EN SORTIE : SINUS DE L'ANGLE DU TRIANGLE EN XP1 C REMARQUE : A1 = ARCSIN( 2*S / L12 * L13 ) C ***************************************************************** REAL TRAGSO REAL XP1(*),XP2(*),XP3(*) INTEGER IDIMC C REAL V12(3),V13(3),L12,L13,XPROD,SURF,PRSCAL,PRVECT REAL COSANG,SINANG,ANGLE EXTERNAL SCALVE,XNORVE REAL SCALVE,XNORVE C CALL DIFFVE(XP2,XP1,IDIMC,V12) L12 = XNORVE(V12,IDIMC) XPROD = L12 C CALL DIFFVE(XP1,XP3,IDIMC,V13) CALL DIFFVE(XP3,XP1,IDIMC,V13) L13 = XNORVE(V13,IDIMC) XPROD = XPROD * L13 CALL VECTVE(V12,V13,IDIMC,PRVECT) PRSCAL = SCALVE(V12,V13,IDIMC) SURF = 0.5 * PRVECT SINANG = PRVECT / XPROD COSANG = PRSCAL / XPROD CALL AGSICO(SINANG,COSANG,ANGLE) TRAGSO = ANGLE 9999 END C C FUNCTION TRRIL(P1,P2,P3) C ***************************************************************** C OBJET TRRIL : RENVOI RI / L DU TRIANGLE 2D C RI = LE RAYON DU CERCLE INSCRIT C L = L'ARETE LA PLUS LONGUE. C C EN ENTREE : C P1, P2, P3 : LES COORDONNEES DES 3 POINTS C C FORMULE : C RIL = SURFACE / (DEMI PERIMETRE * ARETE LA PLUS LONGUE) C ***************************************************************** REAL TRRIL REAL P1(*),P2(*),P3(*) C REAL COEF3 C --- COEF3 = SQRT(3)/2 ------------ C DATA COEF3/.86602540378443864676/ C --- COEF3 = SQRT(3) ------------ REAL XV(3),YV(3),S,P,D,DMAX INTEGER I C COEF3 = 1.73205080756887729352 TRRIL = 0.0 XV(1) = P2(1) - P1(1) YV(1) = P2(2) - P1(2) XV(2) = P3(1) - P2(1) YV(2) = P3(2) - P2(2) XV(3) = P1(1) - P3(1) YV(3) = P1(2) - P3(2) S = (XV(1) * YV(2)) - ( XV(2) * YV(1) ) IF( S.LT.0.0 )GOTO 999 P = 0.0 DMAX = 0.0 DO 10 I=1,3 D = XV(I)**2 + YV(I)**2 D = SQRT(D) IF( D .GT. DMAX )DMAX = D P = P + D 10 CONTINUE TRRIL = ((2. * COEF3 * S) / ( P * DMAX )) 999 END C SUBROUTINE TRLL(XP1,XP2,XP3,DMIN,DMAX) C ***************************************************************** C OBJET TRLL : CALCUL L'ARETE MIN. ET L'ARETE MAX. DU TRIANGLE 2D C C EN ENTREE : C XP1, XP2, XP3 : LES COORDONNEES DES 3 POINTS C C EN SORTIE : C DMIN : LONGUEUR DE L'ARETE LA PLUS COURTE C DMAX : LONGUEUR DE L'ARETE LA PLUS LONGUE C ***************************************************************** REAL XP1(*),XP2(*),XP3(*),DMIN,DMAX C REAL V(3),D EXTERNAL XNORVE REAL XNORVE INTEGER IDIMC C IDIMC = 2 CALL DIFFVE(XP2,XP1,IDIMC,V) DMIN = XNORVE(V,IDIMC) DMAX = DMIN CALL DIFFVE(XP3,XP2,IDIMC,V) D = XNORVE(V,IDIMC) DMIN = MIN( D, DMIN ) DMAX = MAX( D, DMAX ) CALL DIFFVE(XP1,XP3,IDIMC,V) D = XNORVE(V,IDIMC) DMIN = MIN( D, DMIN ) DMAX = MAX( D, DMAX ) 999 END C C SUBROUTINE TRLL2(XP1,XP2,XP3,IDIMC,XLMIN,XLMAX) C ***************************************************************** C OBJET TRLL2 : CALCUL L'ARETE MIN. ET L'ARETE MAX. DU TRIANGLE C C EN ENTREE : C XP1, XP2, XP3 : LES COORDONNEES DES 3 POINTS C C EN SORTIE : C XLMIN : LONGUEUR DE L'ARETE LA PLUS COURTE C XLMAX : LONGUEUR DE L'ARETE LA PLUS LONGUE C ***************************************************************** REAL XP1(*),XP2(*),XP3(*),XLMIN,XLMAX INTEGER IDIMC C REAL V(3),D EXTERNAL XNORVE REAL XNORVE C CALL DIFFVE(XP2,XP1,IDIMC,V) XLMIN = XNORVE(V,IDIMC) XLMAX = XLMIN CALL DIFFVE(XP3,XP2,IDIMC,V) D = XNORVE(V,IDIMC) XLMIN = MIN( D, XLMIN ) XLMAX = MAX( D, XLMAX ) CALL DIFFVE(XP1,XP3,IDIMC,V) D = XNORVE(V,IDIMC) XLMIN = MIN( D, XLMIN ) XLMAX = MAX( D, XLMAX ) 999 END C C FUNCTION TRLMIN(XP1,XP2,XP3,IDIMC) C ***************************************************************** C OBJET TRLL2 : CALCUL L'ARETE MIN DU TRIANGLE C C EN ENTREE : C XP1, XP2, XP3 : LES COORDONNEES DES 3 POINTS C C EN SORTIE : C XLMIN : LONGUEUR DE L'ARETE LA PLUS COURTE C ***************************************************************** REAL TRLMIN REAL XP1(*),XP2(*),XP3(*) INTEGER IDIMC C REAL V(3),D,XLMIN EXTERNAL XNORVE REAL XNORVE C CALL DIFFVE(XP2,XP1,IDIMC,V) XLMIN = XNORVE(V,IDIMC) CALL DIFFVE(XP3,XP2,IDIMC,V) D = XNORVE(V,IDIMC) XLMIN = MIN( D, XLMIN ) CALL DIFFVE(XP1,XP3,IDIMC,V) D = XNORVE(V,IDIMC) XLMIN = MIN( D, XLMIN ) TRLMIN = XLMIN 999 END C C FUNCTION TRLSL2(XP1,XP2,XP3,IDIMC) C ***************************************************************** C OBJET TRLSL2 : RAPPORT MIN/MAX DES LONGUEURS DES ARETES C C EN ENTREE : C XP1, XP2, XP3 : LES COORDONNEES DES 3 POINTS C C EN SORTIE : C ***************************************************************** REAL TRLSL2 REAL XP1(*),XP2(*),XP3(*) INTEGER IDIMC C REAL V(3),D,XLMIN,XLMAX EXTERNAL XNORVE REAL XNORVE C CALL DIFFVE(XP2,XP1,IDIMC,V) XLMIN = XNORVE(V,IDIMC) XLMAX = XLMIN CALL DIFFVE(XP3,XP2,IDIMC,V) D = XNORVE(V,IDIMC) XLMIN = MIN( D, XLMIN ) XLMAX = MAX( D, XLMAX ) CALL DIFFVE(XP1,XP3,IDIMC,V) D = XNORVE(V,IDIMC) XLMIN = MIN( D, XLMIN ) XLMAX = MAX( D, XLMAX ) TRLSL2 = XLMIN / XLMAX 9999 END C C FUNCTION TRLAG2(XP1,XP2,XP3,IDIMC) C ***************************************************************** C OBJET TRLAG2 : SINUS MINIMUM DES ANGLES DU TRIANGLE C C EN ENTREE : C XP1, XP2, XP3 : LES COORDONNEES DES 3 POINTS C C EN SORTIE : C REMARQUE : TETA = ARCSIN( 2*S*LMIN / A*B*C ) C ( ON A AUSSI : TETA = ARCSIN( LMIN / RC ) ) C ***************************************************************** REAL TRLAG2 REAL XP1(*),XP2(*),XP3(*) INTEGER IDIMC C C REAL V12(3),V23(3),V(3),D,XLMIN,XPROD,SURF EXTERNAL XNORVE REAL XNORVE C CALL DIFFVE(XP2,XP1,IDIMC,V12) XLMIN = XNORVE(V12,IDIMC) XPROD = XLMIN CALL DIFFVE(XP3,XP2,IDIMC,V23) D = XNORVE(V23,IDIMC) XPROD = XPROD * D XLMIN = MIN( D, XLMIN ) CALL DIFFVE(XP1,XP3,IDIMC,V) D = XNORVE(V,IDIMC) XPROD = XPROD * D XLMIN = MIN( D, XLMIN ) C CALL VECTVE(V12,V23,IDIMC,V) IF( IDIMC.EQ.3 )THEN SURF = 0.5 * XNORVE(V,IDIMC) ELSE SURF = 0.5 * V(1) ENDIF TRLAG2 = (2.0 * XLMIN * SURF) / XPROD C 9999 END C C FUNCTION TRLRC2(P1,P2,P3,IDIMC) C ***************************************************************** C OBJET TRLRC2 : LMAX / RAYON DU CERCLE CIRC. AU TRIANGLE C C EN ENTREE : C P1, P2, P3 : LES COORDONNEES DES 3 POINTS C C FORMULE : C TTLRC = 0.5 * L/RC C RC = ABC / 4S C ***************************************************************** REAL TRLRC2 REAL P1(*),P2(*),P3(*) INTEGER IDIMC C REAL XLMAX,RSC,V(3),V12(3),V23(3),D,S EXTERNAL NULLVE,XNORVE INTEGER NULLVE REAL XNORVE C TRLRC2 = 0.0 XLMAX = 0.0 RSC = 1.0 CALL DIFFVE(P2,P1,IDIMC,V12) D = XNORVE(V12,IDIMC) XLMAX = MAX(D,XLMAX) RSC = D * RSC CALL DIFFVE(P3,P2,IDIMC,V23) D = XNORVE(V23,IDIMC) XLMAX = MAX(D,XLMAX) RSC = D * RSC CALL DIFFVE(P1,P3,IDIMC,V) D = XNORVE(V,IDIMC) XLMAX = MAX(D,XLMAX) RSC = D * RSC CALL VECTVE(V12,V23,IDIMC,V) IF( IDIMC.EQ.3 )THEN S = 0.5 * XNORVE(V,IDIMC) ELSE S = 0.5 * V(1) ENDIF C PRINT *,'SURFACE = ',S IF( NULLVE(RSC,1).EQ.1 )GOTO 9999 TRLRC2 = 2.0 * S * XLMAX / RSC C PRINT *,' LRC = ',TRLRC2 9999 END C C FUNCTION TRCIRC(P1,P2,P3,IDIMC) C ***************************************************************** C OBJET TRCIRC : RAYON DU CERCLE CIRCONSCRIT AU TRIANGLE C C EN ENTREE : C P1, P2, P3 : LES COORDONNEES DES 3 POINTS C C FORMULE : C RC = ABC / 4S C ***************************************************************** REAL TRCIRC REAL P1(*),P2(*),P3(*) INTEGER IDIMC C REAL RSC,V(3),V12(3),V23(3),D,S EXTERNAL NULLVE,XNORVE INTEGER NULLVE REAL XNORVE C TRCIRC = 0.0 RSC = 1.0 CALL DIFFVE(P2,P1,IDIMC,V12) D = XNORVE(V12,IDIMC) RSC = D * RSC CALL DIFFVE(P3,P2,IDIMC,V23) D = XNORVE(V23,IDIMC) RSC = D * RSC CALL DIFFVE(P1,P3,IDIMC,V) D = XNORVE(V,IDIMC) RSC = D * RSC CALL VECTVE(V12,V23,IDIMC,V) IF( IDIMC.EQ.3 )THEN S = 0.5 * XNORVE(V,IDIMC) ELSE S = 0.5 * V(1) ENDIF C PRINT *,'SURFACE = ', S IF( NULLVE(RSC,1).EQ.1 )GOTO 9999 TRCIRC = RSC / (4. * S) 9999 END C C FUNCTION TRSURF(P1,P2,P3,IDIMC) C ***************************************************************** C OBJET TRSURF : RENVOI LA SURFACE DU TRIANGLE C C EN ENTREE : C P1, P2, P3 : LES COORDONNEES DES 3 POINTS C C FORMULE : C SURFACE = 0.5 * || V12 ^ V23 || C ***************************************************************** REAL TRSURF INTEGER IDIMC REAL P1(*),P2(*),P3(*) C REAL V(3,3),v123(3),UNDEMI EXTERNAL XNORVE REAL XNORVE C UNDEMI = 0.5 CALL DIFFVE(P2,P1,IDIMC,V(1,1)) CALL DIFFVE(P3,P2,IDIMC,V(1,2)) CALL VECTVE(V(1,1),V(1,2),IDIMC,V123) C ---- BUG_33.A : O.STAB, 17.10.97 : ERREUR SUR HP AVEC OPTION (+T) ---- IF( IDIMC.EQ. 2 )THEN TRSURF = UNDEMI * SQRT(V123(1)*V123(1)) ELSE TRSURF = UNDEMI * XNORVE(V123,IDIMC) ENDIF C 9999 END C C SUBROUTINE TRNORM(P1,P2,P3,IDIMC,SURF,XNORM,IERR) C ***************************************************************** C OBJET TRNORM : RENVOI LA NORMALE ET LA SURFACE DU TRIANGLE C C EN ENTREE : C P1, P2, P3 : LES COORDONNEES DES 3 POINTS C C FORMULE : C SURF = 0.5 * || V12 ^ V23 || C XNORM = V12 ^ V23 / (2*SURF) C ***************************************************************** INTEGER IDIMC REAL P1(*),P2(*),P3(*) REAL SURF,XNORM(*) INTEGER IERR C REAL V(3,2),X EXTERNAL XNORVE,NULLVE REAL XNORVE INTEGER NULLVE C CALL DIFFVE(P2,P1,IDIMC,V(1,1)) CALL DIFFVE(P3,P2,IDIMC,V(1,2)) CALL VECTVE(V(1,1),V(1,2),IDIMC,XNORM) SURF = XNORVE(XNORM,IDIMC) IF( NULLVE( SURF, 1 ).EQ.1 )THEN IERR = -1 SURF = 0.0 GOTO 9999 ENDIF X = 1.0 / SURF SURF = 0.5 * SURF CALL MUSCVE( XNORM,X,IDIMC,XNORM ) IERR = 0 C 9999 END C C FUNCTION TRRIL2(P1,P2,P3,IDIMC) C ***************************************************************** C OBJET TRRIL2 : RENVOI RI / L DU TRIANGLE C RI = LE RAYON DU CERCLE INSCRIT C L = L'ARETE LA PLUS LONGUE. C C EN ENTREE : C P1, P2, P3 : LES COORDONNEES DES 3 POINTS C C FORMULE : C RIL = SQRT(3) * SURFACE / (DEMI PERIMETRE * ARETE LA PLUS LONGUE) C ***************************************************************** REAL TRRIL2 INTEGER IDIMC REAL P1(*),P2(*),P3(*) C REAL COEF3 EXTERNAL TRRIL REAL TRRIL REAL V(3,3),v123(3),S,P,D,XLMAX,UNDEMI INTEGER I INTEGER NULLVE EXTERNAL XNORVE,NULLVE REAL XNORVE C IF( IDIMC.EQ. 2 )THEN TRRIL2 = TRRIL(P1,P2,P3) GOTO 999 ENDIF UNDEMI = 0.5 C --- COEF3 = SQRT(3) ------------ COEF3 = 1.73205080756887729352 TRRIL2 = 0.0 CALL DIFFVE(P2,P1,IDIMC,V(1,1)) CALL DIFFVE(P3,P2,IDIMC,V(1,2)) CALL DIFFVE(P1,P3,IDIMC,V(1,3)) CALL VECTVE(V(1,1),V(1,2),IDIMC,V123) S = UNDEMI * XNORVE(V123,IDIMC) IF( NULLVE(S,1).EQ. 1)GOTO 999 C IF( S.LT.0.0 )GOTO 999 P = 0.0 XLMAX = 0.0 DO 10 I=1,3 D = XNORVE(V(1,I),IDIMC) IF( D .GT. XLMAX )XLMAX = D P = P + D 10 CONTINUE TRRIL2 = ((4. * COEF3 * S) / ( P * XLMAX )) 999 END C C ***************************************************************** C MODULE : CG (CALCUL GEOMETRIQUE) C FICHIER : cg_volume.F C OBJET : CALCUL DU VOLUME D'UN POLYEDRE (TRIANGULATION) C FONCT. : C C AUTEUR : O. STAB C DATE : 04.07 C MODIFICATIONS : C AUTEUR, DATE, OBJET : C C ***************************************************************** C FUNCTION PRMIXT(P1,P2,P3,P4) C ***************************************************************** C OBJET PRMXT : PRODUIT MIXTE C C EN ENTREE : C P1, P2, P3, P4 : LES COORDONNEES DES 4 POINTS C C FORMULE : C PRODUIT MIXTE C ***************************************************************** REAL PRMIXT REAL P1(*),P2(*),P3(*),P4(*) C REAL V12(3),V13(3),V14(3),V123(3) INTEGER IDIMC EXTERNAL SCALVE REAL SCALVE C IDIMC = 3 CALL DIFFVE(P2,P1,IDIMC,V12) CALL DIFFVE(P3,P2,IDIMC,V13) CALL VECTVE(V12,V13,IDIMC,V123) CALL DIFFVE(P4,P3,IDIMC,V14) PRMIXT = SCALVE(V123,V14,IDIMC) 9999 END C FUNCTION TRIVOL(P1,P2,P3,K) C ***************************************************************** C OBJET TRIVOL : RENVOI LE VOLUME ELEMENTAIRE ENTRE LE TRIANGLE ET LE PLAN C C EN ENTREE : C P1, P2, P3 : LES COORDONNEES DES 3 POINTS C K : 3 plan XOY, 2 plan XOZ, 1 plan YOZ C C FORMULE : C TRIVO = VOLUME( 2 TETRAEDRE + PRISME ) C ***************************************************************** REAL TRIVOL REAL P1(*),P2(*),P3(*) INTEGER K C EXTERNAL PRMIXT REAL PRMIXT INTEGER IKI,I REAL VKV,P1B(3),P2B(3),P3B(3),P10(3),VOLT1,VOLT2,VOP,UNSIX UNSIX = .16666666666666666666 C recherche du point minimisant Xk IKI = 1 VKV = P1(K) IF( P2(K).LT.VKV )THEN IKI=2 VKV=P2(K) ENDIF IF( P3(K).LT.VKV )THEN IKI=3 VKV=P3(K) ENDIF C copie des points de la base DO 5 I=1,3 P10(I)=P1(I) P1B(I)=P1(I) P2B(I)=P2(I) P3B(I)=P3(I) 5 CONTINUE P10(K)= 0.0 P1B(K)=VKV P2B(K)=VKV P3B(K)=VKV GOTO(10,20,30) IKI 10 CONTINUE VOLT1 = UNSIX*PRMIXT(P1B,P2B,P3B,P2) VOLT2 = UNSIX*PRMIXT(P1B,P2 ,P3B,P3) GOTO 100 20 CONTINUE VOLT1 = UNSIX*PRMIXT(P1B,P2B,P3B,P3) VOLT2 = UNSIX*PRMIXT(P3 ,P1B,P2B,P1) GOTO 100 30 CONTINUE VOLT1 = UNSIX*PRMIXT(P1B,P2B,P3B,P1) VOLT2 = UNSIX*PRMIXT(P1 ,P2B,P3B,P2) GOTO 100 100 CONTINUE VOP = PRMIXT(P1B,P2B,P3B,P10) C WRITE(*,*) 'VOL = ',VOP C WRITE(*,*) 'VOLT1 = ',VOLT1 C WRITE(*,*) 'VOLT2 = ',VOLT2 TRIVOL = VOP + VOLT1+VOLT2 9999 END C ***************************************************************** C MODULE : CG (CALCUL GEOMETRIQUE) C FICHIER : CG_MLT.F C OBJET : SPHERE EN 3D C FONCT. : C OBJET SPTTUT : SPHERE CIRCONSCRITE A UN TETRAEDRE C OBJET SL33UT : SYSTEME LINEAIRE AX=B (3x3) C OBJET MIXTUT : SYSTEME LINEAIRE AX=B (3x3) ET DETERMINANT C OBJET SLDTUT : A.(B^C) = PRODUIT MIXTE (DETERMINANT DE 3 COLONNES) C OBJET VECTUT : C=A^B PRODUIT VECTORIEL C OBJET SCALUT : PRODUIT SCALAIRE C C AUTEUR : S.M.TIJANI C DATE : 03.95 / 04.97 C MODIFICATIONS : C AUTEUR, DATE, OBJET : O.STAB, 95, MISE A LA NORME C C REMARQUE : A FAIRE = OPTIMISATION IN-LINE DANS SPTTUT C ET EVITER LES DOUBLONS VECT SCAL... C METTRE UN PRODUIT MIXTE DANS CG_VECTORIEL ? C ***************************************************************** C C SUBROUTINE SPTTUT(N,X,CC) C ************************************************************* C OBJET SPTTUT : SPHERE CIRCONSCRITE A UN TETRAEDRE C EN ENTREE: C N : TABLEAU DES 4 NOEUDS DU TETRAEDRE C X : COORDONNEES DES NOEUDS (2 DIMENSIONS !) C C EN SORTIE: C CC : TABLEAU DE LA SPHERE C CC(1:3) VECTEUR DIAMETRE (PARTANT DE N(4)) C CC(4) DIAMETRE AU CARRE C ************************************************************* C DIMENSION N(4),X(3,1),CC(4) INTEGER N(4) REAL X(3,1) REAL CC(4) C C N(4) EST PRIS COMME REFERENCE C C COMMON /INFXMLT/ ZERO,GRAN REAL A(3,3),B(3),Y(3) INTEGER K,I,IER EXTERNAL SCALUT REAL SCALUT C DO 20 K=1,3 DO 10 I=1,3 Y(I)=X(I,N(K))-X(I,N(4)) 10 A(K,I)=Y(I) 20 B(K)=SCALUT(Y,Y,3) CALL SL33UT(IER,A,B,CC) IF(IER.EQ.0) THEN CC(4)=CC(1)**2+CC(2)**2+CC(3)**2 RETURN ENDIF DO 30 I=1,4 30 CC(I)=0. RETURN END C C SUBROUTINE SL33UT(IER,A,B,X) C ************************************************************* C OBJET SL33UT : SYSTEME LINEAIRE AX=B (3x3) C EN ENTREE: C A : PREMIER MEMBRE DU SYSTEME C B : SECOND MEMBRE DU SYSTEME C C EN SORTIE: C IER : IER = 0 OK, IER = 1 DETERMINANT NUL C X : RESULTAT DU SYSTEME C ************************************************************* C DIMENSION A(3,3),B(3),X(3) INTEGER IER REAL A(3,3),B(3),X(3) C REAL D,ZERO C ZERO=1.E-30 CALL MIXTUT(A,B,X,D) IER=0 IF(ABS(D).LE.ZERO) IER=1 RETURN END C SUBROUTINE MIXTUT(A,B,X,D) C ************************************************************* C OBJET MIXTUT : SYSTEME LINEAIRE AX=B (3x3) ET DETERMINANT C EN ENTREE: C A : PREMIER MEMBRE DU SYSTEME C B : SECOND MEMBRE DU SYSTEME C EN SORTIE: C D : DETERMINANT DU SYSTEME C X : RESULTAT DU SYSTEME C SI D N'EST PAS NUL C REMARQUE : C IL EST POSSIBLE DE FAIRE L'APPEL COMME SUIT : C CALL STROI(A,B,B,D), B EST LE SECOND MEMBRE A L'ENTREE ET C LA SOLUTION A LA SORTIE. C ************************************************************* C DIMENSION A(3,3),B(3),X(3),D REAL A(3,3),B(3),X(3),D C REAL V(3),X1,X2,X3 EXTERNAL SCALUT,SLDTUT REAL SCALUT,SLDTUT C CALL VECTUT(A(1,2),A(1,3),V) D=SCALUT(A,V,3) IF(D.EQ.0.) RETURN X1=SCALUT(B,V,3)/D X2=SLDTUT(B,A(1,3),A)/D X3=SLDTUT(B,A,A(1,2))/D X(1)=X1 X(2)=X2 X(3)=X3 RETURN END C C FUNCTION SLDTUT(A,B,C) C ************************************************************* C OBJET SLDTUT : A.(B^C) = PRODUIT MIXTE (DETERMINANT DE 3 COLONNES) C EN ENTREE: C A,B,C : LES 3 VECTEURS C EN SORTIE: RENVOI A.(B^C) C ********************************************** C DIMENSION A(3),B(3),C(3),V(3) REAL SLDTUT REAL A(3),B(3),C(3) C REAL V(3) EXTERNAL SCALUT REAL SCALUT C CALL VECTUT(B,C,V) SLDTUT=SCALUT(A,V,3) RETURN END C C SUBROUTINE VECTUT(A,B,C) C ************************************************************* C OBJET VECTUT : C=A^B PRODUIT VECTORIEL C EN ENTREE: C A,B : LES 2 VECTEURS C EN SORTIE: C C : C=A^B C ********************************************** REAL A(3),B(3),C(3) C C(1)=A(2)*B(3)-A(3)*B(2) C(2)=A(3)*B(1)-A(1)*B(3) C(3)=A(1)*B(2)-A(2)*B(1) RETURN END C FUNCTION SCALUT(X,Y,N) C ********************************************** C OBJET SCALUT : PRODUIT SCALAIRE C EN ENTREE: C X,Y : LES 2 VECTEURS C N : LE NOMBRE DE COORDONNEES C EN SORTIE: RENVOI X(1)*Y(1) + X(2)*Y(2) + ... + X(N)*Y(N) C ********************************************** C DIMENSION X(1),Y(1) REAL SCALUT REAL X(*),Y(*) INTEGER N C INTEGER I C SCALUT=0. IF(N.LE.0) RETURN DO 10 I=1,N 10 SCALUT=SCALUT+X(I)*Y(I) RETURN END C C ***************************************************************** C MODULE : CG (CALCUL GEOMETRIQUE) C FICHIER : CG_TETRA.F C OBJET : CALCUL DE LA QUALITE D'UN TETRAEDRE C ET D'UN TRIANGLE EN 3D C FONCT. : C OBJET TTRSC : RAYON DE LA SPHERE CIRC. AU TETRA C OBJET TTLRC : LMAX / RAYON DE LA SPHERE CIRC. AU TETRA C OBJET TTD2SC : DIAM. AU 2 DE LA SPHERE CIRC. AU TETRA C OBJET TTVO : RENVOI LE VOLUME DU TETRAEDRE C OBJET TTSF4 : RENVOI LA SURFACE D'UNE DES 4 FACES DU TETRA C OBJET TTRIL : RENVOI RI / L POUR LE TETRAEDRE C OBJET TTLSL : RENVOI LMIN / LMAX POUR LE TETRAEDRE C OBJET TTLMIN : CALCUL L'ARETE MIN. DU TETRAEDRE C OBJET TTLMAX : CALCUL L'ARETE MAX. DU TETRAEDRE C OBJET GARMXM : CALCULE LE BARYCENTRE D'UN SIMPLEXE C OBJET TRPOOP : CALCUL LE POINT OPTIMUM (FORME TETRA 1,2,3,P ) C AUTEUR : O. STAB C DATE : 03.95 C MODIFICATIONS : C AUTEUR, DATE, OBJET : C C C ***************************************************************** C FUNCTION TTRSC(P1,P2,P3,P4) C ***************************************************************** C OBJET TTRSC : RAYON DE LA SPHERE CIRC. AU TETRA C C EN ENTREE : C P1, P2, P3, P4 : LES COORDONNEES DES 4 POINTS C C FORMULE : C RC = C ***************************************************************** REAL TTRSC REAL P1(*),P2(*),P3(*),P4(*) C REAL DIAM2 REAL TTD2SC INTEGER NULLVE EXTERNAL TTD2SC,NULLVE C DIAM2 = TTD2SC(P1,P2,P3,P4) TTRSC = 0.0 IF( NULLVE(DIAM2,1).NE.1 )TTRSC = SQRT(DIAM2) / 2.0 9999 END C C FUNCTION TTLRC(P1,P2,P3,P4) C ***************************************************************** C OBJET TTLRC : LMAX / RAYON DE LA SPHERE CIRC. AU TETRA C C EN ENTREE : C P1, P2, P3, P4 : LES COORDONNEES DES 4 POINTS C C FORMULE : C TTLRC = (2/3)SQRT(6) * L/RC C ***************************************************************** REAL TTLRC REAL P1(*),P2(*),P3(*),P4(*) C REAL XLMAX,RSC,UNDEMI EXTERNAL TTRSC,TTLMAX,NULLVE REAL TTRSC,TTLMAX INTEGER NULLVE C UNDEMI = 0.5 TTLRC = 0.0 RSC = TTRSC(P1,P2,P3,P4) IF( NULLVE(RSC,1).EQ.1 )GOTO 9999 C XLMAX = TTLMAX(P1,P2,P3,P4) TTLRC = UNDEMI * XLMAX / RSC 9999 END C C FUNCTION TTD2SC(P1,P2,P3,P4) C ***************************************************************** C OBJET TTD2SC : DIAM. AU 2 DE LA SPHERE CIRC. AU TETRA C C EN ENTREE : C P1, P2, P3, P4 : LES COORDONNEES DES 4 POINTS C C FORMULE : C RC = A FAIRE C ***************************************************************** REAL TTD2SC REAL P1(*),P2(*),P3(*),P4(*) C REAL V(3,3),VI(3,3),B(3),CC(4) INTEGER I,K,IERR,IDIMC EXTERNAL XNORVE,SCALVE REAL XNORVE,SCALVE C C DO 20 K=1,3 C DO 10 I=1,3 C Y(I)=X(I,N(K))-X(I,N(4)) C A(K,I)=Y(I) C 10 CONTINUE C C B(K)=SCALXUTL(Y,Y,3) C 20 CONTINUE C CALL SYS3XTET(IER,A,B,CC) C IDIMC = 3 CALL DIFFVE(P1,P4,IDIMC,V(1,1)) CALL DIFFVE(P2,P4,IDIMC,V(1,2)) CALL DIFFVE(P3,P4,IDIMC,V(1,3)) C DO 10 I=1,3 B(I)=SCALVE(V(1,I),V(1,I),3) DO 5 K=1,3 VI(K,I) = V(I,K) 5 CONTINUE 10 CONTINUE CALL SL33UT(IERR,VI,B,CC) IF(IERR.EQ.0) THEN CC(4) = CC(1)**2+CC(2)**2+CC(3)**2 ELSE CC(4) = 0 ENDIF C PRINT*,' DIAM2 = ',CC(4) TTD2SC = CC(4) 9999 END C FUNCTION TTVO(P1,P2,P3,P4) C ***************************************************************** C OBJET TTVO : RENVOI LE VOLUME DU TETRAEDRE C C EN ENTREE : C P1, P2, P3, P4 : LES COORDONNEES DES 4 POINTS C C FORMULE : C TTVO = 1/6 PRODUIT MIXTE C POSITIF SI LES FACES SONT ORIENTEES VERS L'INTERIEUR C ***************************************************************** REAL TTVO REAL P1(*),P2(*),P3(*),P4(*) C REAL V12(3),V13(3),V14(3),V123(3),UNSIX INTEGER IDIMC EXTERNAL SCALVE REAL SCALVE C UNSIX = .16666666666666666666 IDIMC = 3 CALL DIFFVE(P2,P1,IDIMC,V12) CALL DIFFVE(P3,P2,IDIMC,V13) CALL VECTVE(V12,V13,IDIMC,V123) CALL DIFFVE(P4,P3,IDIMC,V14) TTVO = UNSIX * SCALVE(V123,V14,IDIMC) C 9999 END C C FUNCTION TTSF4(IDF,P1,P2,P3,P4) C ***************************************************************** C OBJET TTSF4 : RENVOI LA SURFACE D'UNE DES 4 FACES DU TETRA C C EN ENTREE : C IDF : INDICE DE LA FACE C 1 = (P1,P2,P3), 2 = (P1,P2,P4) C 3 = (P2,P3,P4), 4 = (P3,P1,P4) C C P1, P2, P3, P4 : LES COORDONNEES DES 4 POINTS C C FORMULE : C TTSF = 1/2 NORME(PRODUIT VECTORIEL) C ***************************************************************** REAL TTSF4 REAL P1(*),P2(*),P3(*),P4(*) INTEGER IDF C REAL V12(3),V13(3),V123(3),UNDEMI INTEGER IDIMC EXTERNAL XNORVE REAL XNORVE C UNDEMI = 0.5 IDIMC = 3 GOTO (10,20,30,40) IDF TTSF4 = -1.0 GOTO 9999 C ---- FACE (P1,P2,P3) ------- 10 CALL DIFFVE(P2,P1,IDIMC,V12) CALL DIFFVE(P3,P1,IDIMC,V13) GOTO 50 C ---- FACE (P1,P2,P4) ------- 20 CALL DIFFVE(P2,P1,IDIMC,V12) CALL DIFFVE(P4,P1,IDIMC,V13) GOTO 50 C ---- FACE (P2,P3,P4) ------- 30 CALL DIFFVE(P3,P2,IDIMC,V12) CALL DIFFVE(P4,P2,IDIMC,V13) GOTO 50 C ---- FACE (P3,P1,P4) ------- 40 CALL DIFFVE(P1,P3,IDIMC,V12) CALL DIFFVE(P4,P3,IDIMC,V13) GOTO 50 50 CALL VECTVE(V12,V13,IDIMC,V123) TTSF4 = UNDEMI * XNORVE(V123,IDIMC) C 9999 END C C C FUNCTION TTRIL(P1,P2,P3,P4) C ***************************************************************** C OBJET TTRIL : RENVOI RI / L POUR LE TETRAEDRE C C EN ENTREE : C C P1, P2, P3, P4 : LES COORDONNEES DES 4 POINTS C C FORMULE : RIL = VOL / SOMME DES SURFACES DES FACES C ***************************************************************** REAL TTRIL REAL P1(*),P2(*),P3(*),P4(*) C REAL SURF, VOL, XLMAX, SQ24M3 INTEGER IDIMC,I EXTERNAL TTSF4,TTVO,TTLMAX REAL TTSF4,TTVO,TTLMAX C IDIMC = 3 SURF = 0.0 SQ24M3 = 14.69693845669906858917 DO 10 I=1,4 SURF = TTSF4(I,P1,P2,P3,P4) + SURF 10 CONTINUE C VOL = TTVO(P1,P2,P3,P4) XLMAX = TTLMAX(P1,P2,P3,P4) TTRIL = SQ24M3 * VOL / ( SURF * XLMAX ) C 9999 END C C C C C FUNCTION TTLSL(P1,P2,P3,P4) C ***************************************************************** C OBJET TTLSL : RENVOI LMIN / LMAX POUR LE TETRAEDRE C C EN ENTREE : C C P1, P2, P3, P4 : LES COORDONNEES DES 4 POINTS C C FORMULE : C ***************************************************************** REAL TTLSL REAL P1(*),P2(*),P3(*),P4(*) C REAL XLMIN,XLMAX EXTERNAL TTLMAX,TTLMIN,NULLVE REAL TTLMAX,TTLMIN INTEGER NULLVE C XLMAX = TTLMAX(P1,P2,P3,P4) XLMIN = TTLMIN(P1,P2,P3,P4) TTLSL = 0.0 IF( NULLVE(XLMAX,1).EQ. 1)GOTO 9999 TTLSL = XLMIN / XLMAX C 9999 END C C FUNCTION TTLMIN(XP1,XP2,XP3,XP4) C ***************************************************************** C OBJET TTLMIN : CALCUL L'ARETE MIN. DU TETRAEDRE C C EN ENTREE : C XP1, XP2, XP3, XP4 : LES COORDONNEES DES 4 POINTS C C EN SORTIE : LONGUEUR DE L'ARETE LA PLUS COURTE C ***************************************************************** REAL TTLMIN REAL XP1(*),XP2(*),XP3(*),XP4(*) C REAL V(3),D EXTERNAL XNORVE REAL XNORVE INTEGER IDIMC C C ---- LES ARETES DE LA BASE ---- C IDIMC = 3 CALL DIFFVE(XP2,XP1,IDIMC,V) TTLMIN = XNORVE(V,IDIMC) CALL DIFFVE(XP3,XP2,IDIMC,V) D = XNORVE(V,IDIMC) TTLMIN = MIN( D, TTLMIN ) CALL DIFFVE(XP1,XP3,IDIMC,V) D = XNORVE(V,IDIMC) TTLMIN = MIN( D, TTLMIN ) C C ---- LES ARETES VERS P4 ---- C CALL DIFFVE(XP4,XP1,IDIMC,V) D = XNORVE(V,IDIMC) TTLMIN = MIN( D, TTLMIN ) CALL DIFFVE(XP4,XP2,IDIMC,V) D = XNORVE(V,IDIMC) TTLMIN = MIN( D, TTLMIN ) CALL DIFFVE(XP4,XP3,IDIMC,V) D = XNORVE(V,IDIMC) TTLMIN = MIN( D, TTLMIN ) C 9999 END C C FUNCTION TTLMAX(XP1,XP2,XP3,XP4) C ***************************************************************** C OBJET TTLMAX : CALCUL L'ARETE MAX. DU TETRAEDRE C C EN ENTREE : C XP1, XP2, XP3, XP4 : LES COORDONNEES DES 4 POINTS C C EN SORTIE : LONGUEUR DE L'ARETE LA PLUS LONGUE C ***************************************************************** REAL TTLMAX REAL XP1(*),XP2(*),XP3(*),XP4(*) C REAL V(3),D EXTERNAL XNORVE REAL XNORVE INTEGER IDIMC C C ---- LES ARETES DE LA BASE ---- C IDIMC = 3 CALL DIFFVE(XP2,XP1,IDIMC,V) TTLMAX = XNORVE(V,IDIMC) CALL DIFFVE(XP3,XP2,IDIMC,V) D = XNORVE(V,IDIMC) TTLMAX = MAX( D, TTLMAX ) CALL DIFFVE(XP1,XP3,IDIMC,V) D = XNORVE(V,IDIMC) TTLMAX = MAX( D, TTLMAX ) C C ---- LES ARETES VERS P4 ---- C CALL DIFFVE(XP4,XP1,IDIMC,V) D = XNORVE(V,IDIMC) TTLMAX = MAX( D, TTLMAX ) CALL DIFFVE(XP4,XP2,IDIMC,V) D = XNORVE(V,IDIMC) TTLMAX = MAX( D, TTLMAX ) CALL DIFFVE(XP4,XP3,IDIMC,V) D = XNORVE(V,IDIMC) TTLMAX = MAX( D, TTLMAX ) C 9999 END C C SUBROUTINE GARMXM(IT, NBN, COORD, IDIMC, > XLMIN,IMIN,XLMAX,IMAX, IERR) C ***************************************************************** C OBJET GARMXM : CALCULE LE BARYCENTRE D'UN SIMPLEXE C EN ENTREE : C IT : NUMERO DES NOEUDS DE L'ELEMENT C N : NOMBRE DE NOEUDS DE L'ELEMENT C C : COORDONNEES DES NOEUDS C IDIMC : DIMENSION DE L'ESPACE C EN SORTIE : C XLMIN, XLMAX : LONGUEUR MINI ET MAXI DES ARETES DE L'ELEMENT C IMIN, IMAX : INDICE RELATIF DE L'ARETE LA PLUS COURTE (LONGUE) C IERR : 0 SI OK, -1 SI LES DONNEES SONT ERRONEES C ***************************************************************** INTEGER IT(*),NBN,IDIMC,IERR REAL COORD(*),XLMIN,XLMAX INTEGER IMIN,IMAX C INTEGER I,J REAL X(3),XM(3) C IERR = 0 GOTO (10,20,30,30) NBN C --- SOMMET --- 10 IERR = -1 GOTO 9999 C C --- ARETE --- C ======= 20 IMIN = 1 IMAX = 1 XLMIN = 0.0 DO 25 J=1,IDIMC X(J) = COORD(((IT(2)-1)*IDIMC)+J) > - COORD(((IT(1)-1)*IDIMC)+J) XLMIN = XLMIN + X(J)*X(J) 25 CONTINUE XLMIN = SQRT(XLMIN) XLMAX = XLMIN GOTO 9999 C C --- TRIANGLES ET TETRAEDRES ---- C ========================== 30 DO 40 J=1,IDIMC X(1) = COORD(((IT(2)-1)*IDIMC)+J) > - COORD(((IT(1)-1)*IDIMC)+J) XM(1) = XM(1) + X(1) * X(1) X(2) = COORD(((IT(3)-1)*IDIMC)+J) > - COORD(((IT(2)-1)*IDIMC)+J) XM(2) = XM(2) + X(2) * X(2) X(3) = COORD(((IT(1)-1)*IDIMC)+J) > - COORD(((IT(3)-1)*IDIMC)+J) XM(3) = XM(3) + X(3) * X(3) 40 CONTINUE C XLMIN = XM(1) XLMAX = XM(1) IMIN = 1 IMAX = 1 DO 50 I=2,3 IF( XLMAX .LT. X(I) )THEN XLMAX = X(I) IMAX = I ENDIF IF( XLMIN .GT. X(I) )THEN XLMIN = X(I) IMIN = I ENDIF 50 CONTINUE IF( NBN.EQ. 3)GOTO 9999 C C --- TETRAEDRES SEULEMENT ---- C ========================== DO 60 J=1,IDIMC X(1) = COORD(((IT(4)-1)*IDIMC)+J) > - COORD(((IT(1)-1)*IDIMC)+J) XM(1) = XM(1) + X(1) * X(1) X(2) = COORD(((IT(4)-1)*IDIMC)+J) > - COORD(((IT(2)-1)*IDIMC)+J) XM(2) = XM(2) + X(2) * X(2) X(3) = COORD(((IT(4)-1)*IDIMC)+J) > - COORD(((IT(3)-1)*IDIMC)+J) XM(3) = XM(3) + X(3) * X(3) 60 CONTINUE DO 70 I=1,3 IF( XLMAX .LT. X(I) )THEN XLMAX = X(I) IMAX = I+3 ENDIF IF( XLMIN .GT. X(I) )THEN XLMIN = X(I) IMIN = I+3 ENDIF 70 CONTINUE C 9999 END C SUBROUTINE TRPOOP(XP1,XP2,XP3,BARYTR,NORMTR,POINTR,IERR) C ***************************************************************** C OBJET TRPOOP : CALCUL LE POINT OPTIMUM (FORME TETRA 1,2,3,P ) C C EN ENTREE : C XP1, XP2, XP3 : LES COORDONNEES DES 3 POINTS (ORIENTES) C C EN SORTIE : C BARYTR: BARYCENTRE DU TRIANGLE C NORMTR: NORMALE AU TRIANGLE C POINTR: COORDONNEES DU POINT OPTIMUM C IERR : 0 SI OK, -1 SI XP1,XP2,XP3 ALIGNES C C REMARQUES : C POINTR = HAUTEUR * NORMALE AU BARYCENTRE C HAUTEUR= PERIMETRE / 3 C ***************************************************************** REAL XP1(*),XP2(*),XP3(*) REAL BARYTR(*),NORMTR(*),POINTR(*) INTEGER IERR C REAL D,UNS3,UNSD,PERIM,COEF,V(3),V12(3),V23(3) EXTERNAL XNORVE,NULLVE REAL XNORVE INTEGER NULLVE INTEGER IDIMC,I C UNS3 = 1.0 / 3.0 IDIMC = 3 C C ---- PERIMETRE ---- C PERIM = 0.0 C CALL DIFFVE(XP2,XP1,IDIMC,V) D = XNORVE(V,IDIMC) IF( NULLVE(D,1).EQ.1 )THEN IERR = -1 CALL DSERRE(1,IERR,'TROOP','POINTS 1 ET 2 CONFONDUS') GOTO 9999 ENDIF PERIM = PERIM + D UNSD = 1.0 / D CALL MUSCVE(V,UNSD,IDIMC,V12) C CALL DIFFVE(XP3,XP2,IDIMC,V) D = XNORVE(V,IDIMC) IF( NULLVE(D,1).EQ.1 )THEN IERR = -1 CALL DSERRE(1,IERR,'TROOP','POINTS 2 ET 3 CONFONDUS') GOTO 9999 ENDIF PERIM = PERIM + D UNSD = 1.0 / D CALL MUSCVE(V,UNSD,IDIMC,V23) C CALL DIFFVE(XP3,XP1,IDIMC,V) IF( NULLVE(D,1).EQ.1 )THEN IERR = -1 CALL DSERRE(1,IERR,'TROOP','POINTS 3 ET 1 CONFONDUS') GOTO 9999 ENDIF D = XNORVE(V,IDIMC) PERIM = PERIM + D C PRINT *,'PERIMETRE = ',PERIM C C ---- NORMALE ---- C CALL VECTVE(V12,V23,IDIMC,NORMTR) C --- POUR PLUS DE SECURITE --- D = XNORVE(NORMTR,IDIMC) IF( NULLVE(D,1).EQ.1 )THEN IERR = -1 CALL DSERRE(1,IERR,'TROOP','3 POINTS ALIGNES') GOTO 9999 ENDIF COEF = 1.0 / D CALL MUSCVE(NORMTR,COEF,IDIMC,NORMTR) C C PRINT *,'NORMALE = ',(NORMTR(I),I=1,3) C C ---- BARYCENTRE ---- C CALL SOMMVE(XP2,XP1,IDIMC,BARYTR) CALL SOMMVE(BARYTR,XP3,IDIMC,BARYTR) CALL MUSCVE(BARYTR,UNS3,IDIMC,BARYTR) C C PRINT *,'BARYCENTRE = ',(BARYTR(I),I=1,3) C C ---- POINT OPTIMUM ---- C COEF = PERIM / 3.0 CALL MUSCVE(NORMTR,COEF,IDIMC,POINTR) CALL SOMMVE(BARYTR,POINTR,IDIMC,POINTR) IERR = 0 C C PRINT *,'POINT = ',(POINTR(I),I=1,3) C 9999 END C C ***************************************************************** C MODULE : CG (CALCULS GEOMETRIQUES) C FICHIER : GG_SIMPLEXE.F C OBJET : CALCULS GEOMETRIQUES ELEMENTAIRES SUR LES SIMPLEXES C FONCT. : C CGTASX : CALCULE LA TAILLE D'UN SIMPLEXE C CGORSX: RENVOI L'ORIENTATION D'UN SIMPLEXE (SIGNE VOLUME) C C AUTEUR : O. STAB C DATE : 12.97 C TESTS : C MODIFICATIONS : C AUTEUR, DATE, OBJET : C C C ***************************************************************** C SUBROUTINE CGTASX(IPOINT, NBPOIN, COORD, TAILLE, IERR ) C ***************************************************************** C OBJET CGTASX : CALCULE LA TAILLE D'UN SIMPLEXE C EN ENTREE : C IPOINT : NUMERO DES SOMMETS DU SIMPLEXE C NBPOIN : NOMBRE DE SOMMET DU SIMPLEXE C COORD : COORDONNEES DES NOEUDS C EN SORTIE : C TAILLE : LONGUEUR D'UN SEGMENT EN 1D C SURFACE D'UN TRIANGLE EN 2D C VOLUME D'UN TETRAEDRE EN 3D C IERR : 0 SI OK, -1 SI LES DONNEES SONT ERRONEES C ***************************************************************** INTEGER IPOINT(*),NBPOIN REAL COORD(*) REAL TAILLE INTEGER IERR C INTEGER I,J,IDIMC REAL X(12),VX,VY,VZ C TAILLE = 0.0 IF((NBPOIN.GT.4).OR.(NBPOIN.LT.1))THEN IERR = -3 GOTO 9999 ENDIF IERR = 0 IDIMC = NBPOIN-1 IF(NBPOIN.EQ.1)GOTO 9999 DO 10 I=1,(NBPOIN-1) DO 20 J=1,IDIMC X((I-1)*IDIMC+J) = COORD(((IPOINT(I+1)-1)*IDIMC)+J) > - COORD(((IPOINT(I)-1)*IDIMC)+J) 20 CONTINUE 10 CONTINUE IF( IDIMC .EQ. 3 )THEN VX = (X(2) * X(6)) - (X(5) * X(3)) VY = (X(3) * X(4)) - (X(6) * X(1)) VZ = (X(1) * X(5)) - (X(4) * X(2)) ENDIF C GOTO (100,200,300) IDIMC C UN POINT GOTO 9999 C LONGUEUR DU SEGMENT 100 TAILLE = X(1) GOTO 9999 C SURFACE DU TRIANGLE 200 TAILLE = 0.5 *((X(1) * X(4)) - (X(2) * X(3))) GOTO 9999 C VOLUME DU TETRAEDRE 300 CONTINUE VX = (X(2) * X(6)) - (X(5) * X(3)) VY = (X(3) * X(4)) - (X(6) * X(1)) VZ = (X(1) * X(5)) - (X(4) * X(2)) TAILLE = ((VX * X(7)) + (VY * X(8)) + (VZ * X(9))) / 6. GOTO 9999 C 9999 END C FUNCTION CGORSX(IPOINT, NBPOIN, COORD, ZERO, IERR ) C ***************************************************************** C OBJET CGORSX: RENVOI L'ORIENTATION D'UN SIMPLEXE (SIGNE VOLUME) C EN ENTREE : C IPOINT : NUMERO DES SOMMETS DU SIMPLEXE C NBPOIN : NOMBRE DE SOMMET DU SIMPLEXE C COORD : COORDONNEES DES NOEUDS C ZERO : LONGUEUR,SURFACE,VOLUME CONSIDEREE COMME NUL C EN SORTIE : C IERR : 0 SI OK, -1 SI LES DONNEES SONT ERRONEES C ***************************************************************** INTEGER CGORSX INTEGER IPOINT(*),NBPOIN REAL COORD(*),ZERO INTEGER IERR C REAL TAILLE C CALL CGTASX(IPOINT, NBPOIN, COORD, TAILLE, IERR ) IF( TAILLE .GT. ZERO )THEN CGORSX = 1 ELSE IF( TAILLE .LT. -ZERO )THEN CGORSX = -1 ELSE CGORSX = 0 ENDIF ENDIF 9999 END C C ***************************************************************** C MODULE : CG (CALCUL GEOMETRIQUE) C FICHIER : CG_QUAD.F C OBJET : CALCUL DE LA QUALITE D'UN QUADRANGLE C FONCT. : C Q4LL : CALCUL L'ARETE MIN. ET L'ARETE MAX. C C AUTEUR : O. STAB C DATE : 03.95 C MODIFICATIONS : C AUTEUR, DATE, OBJET : O.STAB, 10.97, AJOUT DANS V.2.0.0 C C C ***************************************************************** C C SUBROUTINE Q4LL(XP1,XP2,XP3,XP4,IDIMC,DMIN,DMAX) C ***************************************************************** C OBJET Q4LL : CALCUL L'ARETE MIN. ET L'ARETE MAX. C C EN ENTREE : C XP1, XP2, XP3 : LES COORDONNEES DES 3 POINTS C C EN SORTIE : C DMIN : LONGUEUR DE L'ARETE LA PLUS COURTE C DMAX : LONGUEUR DE L'ARETE LA PLUS LONGUE C ***************************************************************** REAL XP1(*),XP2(*),XP3(*),XP4(*),DMIN,DMAX INTEGER IDIMC C REAL V(3),D EXTERNAL XNORVE REAL XNORVE C CALL DIFFVE(XP2,XP1,IDIMC,V) DMIN = XNORVE(V,IDIMC) DMAX = DMIN CALL DIFFVE(XP3,XP2,IDIMC,V) D = XNORVE(V,IDIMC) DMIN = MIN( D, DMIN ) DMAX = MAX( D, DMAX ) CALL DIFFVE(XP4,XP3,IDIMC,V) D = XNORVE(V,IDIMC) DMIN = MIN( D, DMIN ) DMAX = MAX( D, DMAX ) CALL DIFFVE(XP1,XP4,IDIMC,V) D = XNORVE(V,IDIMC) DMIN = MIN( D, DMIN ) DMAX = MAX( D, DMAX ) 999 END C C FUNCTION Q4SURF(P1,P2,P3,P4,IDIMC) C ***************************************************************** C OBJET Q4SURF : RENVOI LA SURFACE DU QUADRANGLE (A REVOIR) C C EN ENTREE : C P1, P2, P3, P4 : LES COORDONNEES DES 3 POINTS C C FORMULE : C SURFACE = SOMME DES SURFACES DES 2 TRIANGLES ! C ***************************************************************** REAL Q4SURF INTEGER IDIMC REAL P1(*),P2(*),P3(*),P4(*) C C REAL V(3,3),V123(3),UNDEMI,TRSURF EXTERNAL XNORVE REAL XNORVE C C ---- PREMIER TRIANGLE --- C UNDEMI = 0.5 CALL DIFFVE(P2,P1,IDIMC,V(1,1)) CALL DIFFVE(P3,P2,IDIMC,V(1,2)) CALL VECTVE(V(1,1),V(1,2),IDIMC,V123) IF( IDIMC.EQ. 2 )THEN TRSURF = UNDEMI * SQRT(V123(1)*V123(1)) ELSE TRSURF = UNDEMI * XNORVE(V123,IDIMC) ENDIF C C ---- SECOND TRIANGLE --- C CALL DIFFVE(P4,P3,IDIMC,V(1,1)) CALL DIFFVE(P1,P4,IDIMC,V(1,2)) CALL VECTVE(V(1,1),V(1,2),IDIMC,V123) IF( IDIMC.EQ. 2 )THEN Q4SURF = TRSURF + UNDEMI * SQRT(V123(1)*V123(1)) ELSE Q4SURF = TRSURF + UNDEMI * XNORVE(V123,IDIMC) ENDIF C 9999 END C *************************************************************** C MODULE : CG (CALCUL GEOMETRIQUE) C FICHIER : CG_VECTORIEL.F C OBJET : CALCULS ELEMENTAIRES SUR LES VECTEURS C C FONCT. : C COPIVE : COPIE UN VECTEUR DANS UN AUTRE C SCALVE : PRODUIT SCALAIRE C VECTVE : PRODUIT VECTORIEL C XNORVE : RENVOI LA NORME D'UN VECTEUR C NULLVE : RENVOI 1 SI LE VECTEUR EST NUL C DIFFVE : FAIT LA DIFFERENCE ENTRE 2 VECTEURS C SOMMVE : FAIT LA SOMME DE 2 VECTEURS C MUSCVE : MULTIPLICATION D'UN VECTEUR PAR UN SCALAIRE C C AUTEUR : O. STAB C DATE : 03.95 / 06.95 C TESTS : 07.95 C MODIFICATIONS : C AUTEUR, DATE, OBJET : C C C *************************************************************** C A INCLURE DANS LES PROCEDURES UTILISANT LE PACKAGE C C EXTERNAL SCALVE,XNORVE,NULLVE C REAL SCALVE,XNORVE C INTEGER NULLVE C C *************************************************************** C SUBROUTINE COPIVE(V1,IDIMC,V2) C *************************************************************** C COPIE UN VECTEUR DANS UN AUTRE : V2 <- V1 C *************************************************************** INTEGER IDIMC REAL V1(*),V2(*) C INTEGER I C IF(IDIMC.LE.0) RETURN DO 10 I=1,IDIMC V2(I) = V1(I) 10 CONTINUE END C FUNCTION SCALVE(V1,V2,IDIMC) C *************************************************************** C PRODUIT SCALAIRE C SCALVE = V1(1)*V2(1) + V1(2)*V2(2) + ... + V1(N)'V2(N) C *************************************************************** REAL SCALVE INTEGER IDIMC REAL V1(*),V2(*) C INTEGER I C SCALVE = 0. IF(IDIMC.LE.0) RETURN DO 10 I=1,IDIMC SCALVE = SCALVE + V1(I)*V2(I) 10 CONTINUE END C FUNCTION XNORVE(V1,IDIMC) C *************************************************************** C NORME D'UN VECTEUR C *************************************************************** REAL XNORVE INTEGER IDIMC REAL V1(*) C COMMON /CGEPSI/ XYZHUG,XYZMIN,XYZEPS,XYZHU2,XYZMI2 REAL XYZHUG,XYZMIN,XYZEPS,XYZHU2,XYZMI2 INTEGER I C XNORVE = 0. IF(IDIMC.LE.0) RETURN C XNORVE = SCALVE(V1,V1,IDIMC) C MODIF O.STAB, REMPLACE A CAUSE DE L'UNDERFLOW LE 05.12.97 PAR : DO 10 I=1,IDIMC C IF(( V1(I).GT. XYZEPS ).OR.(V1(I).LT.-XYZEPS))THEN IF(( V1(I).GT. XYZMI2 ).OR.(V1(I).LT.-XYZMI2))THEN XNORVE = XNORVE + V1(I)*V1(I) ENDIF 10 CONTINUE C IF( XNORVE .LT. XYZEPS*XYZEPS )THEN IF( XNORVE .LT. XYZMI2 )THEN XNORVE = 0.0 ELSE XNORVE = SQRT( XNORVE ) ENDIF END C SUBROUTINE DIFFVE(V1,V2,IDIMC,V12) C *************************************************************** C FAIT LA DIFFERENCE ENTRE 2 VECTEURS V12 = V1 - V2 C *************************************************************** INTEGER IDIMC REAL V1(*),V2(*),V12(*) C INTEGER I C IF(IDIMC.LE.0) RETURN DO 10 I=1,IDIMC V12(I) = V1(I) - V2(I) 10 CONTINUE END C SUBROUTINE SOMMVE(V1,V2,IDIMC,V12) C *************************************************************** C FAIT LA SOMME ENTRE 2 VECTEURS V12 = V1 + V2 C *************************************************************** INTEGER IDIMC REAL V1(*),V2(*),V12(*) C INTEGER I C IF(IDIMC.LE.0) RETURN DO 10 I=1,IDIMC V12(I) = V1(I) + V2(I) 10 CONTINUE END C SUBROUTINE MUSCVE(V1,SCAL,IDIMC,VSL) C *************************************************************** C MULTIPLIE UN VECTEUR PAR UN SCALAIRE VSL = SCAL * V1 C *************************************************************** INTEGER IDIMC REAL V1(*),SCAL,VSL(*) C INTEGER I C IF(IDIMC.LE.0) RETURN DO 10 I=1,IDIMC VSL(I) = SCAL * V1(I) 10 CONTINUE END C SUBROUTINE VECTVE(V1,V2,IDIMC,PRV) C *************************************************************** C CALCUL LE PRODUIT VECTORIEL C MODIF 09.02.1999 O.STAB : SUPPRESSION DES MISE A ZERO !!! C *************************************************************** INTEGER IDIMC REAL V1(*),V2(*),PRV(*) C C COMMON /CGEPSI/ XYZHUG,XYZMIN,XYZEPS C REAL XYZHUG,XYZMIN,XYZEPS C GOTO (10,20,30) IDIMC GOTO 999 10 PRV(1) = V1(1) * V2(1) C IF((PRV(1).LT.XYZEPS ).AND.( PRV(1).GT.-XYZEPS))PRV(1) = 0.0 GOTO 999 20 PRV(1) = V1(1) * V2(2) - V1(2) * V2(1) C IF((PRV(1).LT.XYZEPS ).AND.( PRV(1).GT.-XYZEPS))PRV(1) = 0.0 GOTO 999 30 PRV(1) = V1(2) * V2(3) - V1(3) * V2(2) C IF((PRV(1).LT.XYZEPS ).AND.( PRV(1).GT.-XYZEPS))PRV(1) = 0.0 PRV(2) = V1(3) * V2(1) - V1(1) * V2(3) C IF((PRV(2).LT.XYZEPS ).AND.( PRV(2).GT.-XYZEPS))PRV(2) = 0.0 PRV(3) = V1(1) * V2(2) - V1(2) * V2(1) C IF((PRV(3).LT.XYZEPS ).AND.( PRV(3).GT.-XYZEPS))PRV(3) = 0.0 999 END C FUNCTION NULLVE(V,IDIMC) C *************************************************************** C RENVOI 1 SI LE VECTEUR EST NUL, O SI NON NUL C *************************************************************** INTEGER NULLVE INTEGER IDIMC REAL V(*) C INTEGER I COMMON /CGEPSI/ XYZHUG,XYZMIN,XYZEPS REAL XYZHUG,XYZMIN,XYZEPS C NULLVE = 0 IF(IDIMC.LE.0) RETURN DO 10 I=1,IDIMC IF(( V(I) .GT. XYZEPS ).OR.( V(I) .LT. -XYZEPS ))RETURN 10 CONTINUE NULLVE = 1 END C ***************************************************************** C MODULE : CG (CALCUL GEOMETRIQUE) C FICHIER : CG_PLAN.F C OBJET : GEOMETRIE 3D - CALCULS SUR LES PLANS C FONCT. : C OBJET M33DPN : 3 VECTEURS ORTHONORMES REPERE DU PLAN (NORMALE=3) C OBJET VEDUPN : UN VECTEUR DU PLAN C OBJET PODUPN : UN POINT DU PLAN C OBJET PNVEPO : CALCULE L'EQUATION DU PLAN (3D) C OBJET POPLDR : CALCULE LE POINT D'INTERSECTION D'UN PLAN ET D'UNE DROITE C OBJET POVEPN : CALCULE UN POINT ET LA NORMALE DU PLAN C OBJET INPNDR : INTERSECTION D'UN PLAN ET D'UNE DROITE C OBJET PL3PO : CALCULE LE PLAN PASSANT PAR LES 3 POINTS C OBJET PLMCAR : CALCULE LE PLAN DES MOINDRES CARRES DE N POINTS C OBJET PRONUL : CALCUL LA VALEUR PROPRE NULLE DE LA MATRICE S. C OBJET RPPNCR : PASSAGE DANS LE REPERE DU PLAN DES MOINDRES CARRES C C AUTEUR : O. STAB C DATE : 97 C TESTS : C MODIFICATIONS : C AUTEUR, DATE, OBJET : C C REMARQUES : PN EST L'ABREVIATION DE PLAN, PL CELLE DE POLYGONE ! C ***************************************************************** C SUBROUTINE M33DPN(XPLAN,XVEC1,XVEC2,XVEC3,IERR) C ***************************************************************** C OBJET M33DPN : 3 VECTEURS ORTHONORMES REPERE DU PLAN (NORMALE=3) C EN ENTREE : XPLAN : EQUATION DU PLAN AX+BY+CZ+D = 0 C EN SORTIE : XMAT44 : MATRICE HOMOGENE DU PLAN C IERR : 0 SI OK, -1 SI "PLAN" N'EST PAS CORRECT C ***************************************************************** REAL XPLAN(4) REAL XVEC1(3),XVEC2(3),XVEC3(3) INTEGER IERR C COMMON /CGEPSI/ XYZHUG,XYZMIN,XYZEPS REAL XYZHUG,XYZMIN,XYZEPS C INTEGER IDIMC REAL XN REAL XNORVE,SCALVE EXTERNAL XNORVE,SCALVE C IDIMC = 3 CALL VEDUPN( XPLAN, XVEC1, IERR ) IF( IERR.NE.0 )THEN CALL DSERRE(1,IERR,'M33DPN','APPEL VEDUPN') GOTO 9999 ENDIF XN = XNORVE(XVEC1,IDIMC) IF( XN.LT.XYZMIN )THEN IERR = -1 CALL DSERRE(1,IERR,'M33DPN ','PLAN NUL !!!') GOTO 9999 ENDIF XN = 1.0 / XN CALL MUSCVE( XVEC1,XN,IDIMC,XVEC1 ) C CALL VECTVE( XPLAN,XVEC1,IDIMC,XVEC2 ) XN = XNORVE( XVEC2,IDIMC ) IF( XN.LT.XYZMIN )THEN IERR = -1 CALL DSERRE(1,IERR,'M33DPN ','BUG !!!') GOTO 9999 ENDIF XN = 1.0 / XN CALL MUSCVE( XVEC2,XN,IDIMC,XVEC2 ) CALL COPIVE( XPLAN,IDIMC,XVEC3 ) C IERR = 0 C 9999 END C C SUBROUTINE VEDUPN( XPLAN, XVECTE, IERR ) C ***************************************************************** C OBJET VEDUPN : UN VECTEUR DU PLAN C EN ENTREE : XPLAN : EQUATION DU PLAN AX+BY+CZ+D = 0 C EN SORTIE : XVECTE : UN VECTEUR DU PLAN C IERR : 0 SI OK, -1 SI "PLAN" N'EST PAS CORRECT C ***************************************************************** REAL XPLAN(4) REAL XVECTE(3) INTEGER IERR C COMMON /CGEPSI/ XYZHUG,XYZMIN,XYZEPS REAL XYZHUG,XYZMIN,XYZEPS C INTEGER ICHOIX,I REAL XNORVE,SCALVE EXTERNAL XNORVE,SCALVE C ICHOIX = 1 DO 5 I=1,3 IF((XPLAN(I).LE.XYZMIN).AND.(XPLAN(I).GE.-XYZMIN))ICHOIX = I 5 CONTINUE IERR = 0 C GOTO(10,20,30) ICHOIX 10 CONTINUE XVECTE(1) = 0.0 XVECTE(2) = XPLAN(3) XVECTE(3) = -XPLAN(2) GOTO 9999 20 CONTINUE XVECTE(1) = -XPLAN(3) XVECTE(2) = 0.0 XVECTE(3) = XPLAN(1) GOTO 9999 30 CONTINUE XVECTE(1) = XPLAN(2) XVECTE(2) = -XPLAN(1) XVECTE(3) = 0.0 GOTO 9999 C 9999 END C C SUBROUTINE PODUPN( XPLAN, XPOINT, IERR ) C ***************************************************************** C OBJET PODUPN : UN POINT DU PLAN C EN ENTREE : XPLAN : EQUATION DU PLAN AX+BY+CZ+D = 0 C EN SORTIE : XPOINT : UN POINT DU PLAN C IERR : 0 SI OK, -1 SI "PLAN" N'EST PAS CORRECT C ***************************************************************** REAL XPLAN(4) REAL XPOINT(3) INTEGER IERR C COMMON /CGEPSI/ XYZHUG,XYZMIN,XYZEPS REAL XYZHUG,XYZMIN,XYZEPS C INTEGER IPLMAX,I REAL XPLMAX C IERR = -1 XPOINT(1) = 0.0 XPOINT(2) = 0.0 XPOINT(3) = 0.0 IF((XPLAN(4).LE.XYZMIN).AND.(XPLAN(4).GE.-XYZMIN))THEN IERR = 0 GOTO 9999 ENDIF C XPLMAX = 0.0 IPLMAX = 0 DO 10 I=1,3 IF(ABS(XPLAN(I)).GT.XPLMAX)THEN IPLMAX = I XPLMAX = ABS(XPLAN(I)) ENDIF 10 CONTINUE C IF( IPLMAX.EQ.0 )THEN IERR = -1 CALL DSERRE(1,IERR,'PODUPN',' PLAN NUL ') GOTO 9999 ENDIF C ---- XPOINT(IPLMAX) = - XPLAN(4) / XPLAN(IPLMAX) IERR = 0 C 9999 END C C SUBROUTINE PNVEPO( XPOINT,VEDIR,XPLAN, IERR ) C ***************************************************************** C OBJET PNVEPO : CALCULE L'EQUATION DU PLAN (3D) C EN ENTREE : C XPOINT : UN POINT DU PLAN C VEDIR : LE VECTEUR NORMAL AU PLAN C EN SORTIE : C XPLAN : EQUATION DU PLAN AX+BY+CZ+D = 0 C IERR : 0 SI OK, -1 SI "PLAN" N'EST PAS CORRECT C ***************************************************************** REAL XPOINT(3),VEDIR(3) REAL XPLAN(4) INTEGER IERR C COMMON /CGEPSI/ XYZHUG,XYZMIN,XYZEPS REAL XYZHUG,XYZMIN,XYZEPS C REAL XNORVE,SCALVE EXTERNAL XNORVE,SCALVE C INTEGER IDIMC REAL SNODIR C IDIMC = 3 C --- NORMALE AU PLAN --- SNODIR = XNORVE(VEDIR,IDIMC) IF( SNODIR.LT.XYZEPS )THEN IERR = -1 GOTO 9999 ENDIF SNODIR= 1.0 / SNODIR CALL MUSCVE(VEDIR,SNODIR,IDIMC,XPLAN) C --- CALCUL DU POINT --- XPLAN(4) = - SCALVE(XPLAN,XPOINT,IDIMC) C PRINT *,'PNVEPO : PLAN = ',XPLAN(1),' * X + ', C > XPLAN(2),' * Y + ', C > XPLAN(3),' * Z + ', C > XPLAN(4) C 9999 END C C SUBROUTINE POPLDR( XPLAN, XPOIDR,VDIRDR, ABCDR, IERR ) C ***************************************************************** C OBJET POPLDR : CALCULE LE POINT D'INTERSECTION D'UN PLAN ET D'UNE DROITE C EN ENTREE : C XPLAN : EQUATION DU PLAN AX+BY+CZ+D = 0 C XPOIDR : UN POINT DE LA DROITE C VDIRDR : LE VECTEUR DIRECTEUR DE LA DROITE C EN SORTIE : C ABCDR : L'ABSCISSE SUR LA DROITE CORRESPONDANT A L'INTERSECTION C IERR : 0 SI OK, -1 SI PAS D'INTERSECTION C ***************************************************************** REAL XPLAN(4),XPOIDR(3),VDIRDR(3) REAL ABCDR INTEGER IERR C COMMON /CGEPSI/ XYZHUG,XYZMIN,XYZEPS REAL XYZHUG,XYZMIN,XYZEPS C REAL SCALVE EXTERNAL SCALVE C INTEGER IDIMC REAL XDENOM,XNUMER C IDIMC = 3 XDENOM = SCALVE(XPLAN,VDIRDR,IDIMC) IF((XDENOM.LT. XYZEPS).AND.(XDENOM.GT.-XYZEPS))THEN IERR = -1 GOTO 9999 ENDIF XNUMER = SCALVE(XPLAN,XPOIDR,IDIMC) + XPLAN(4) ABCDR = XNUMER / XDENOM IERR = 0 C 9999 END C SUBROUTINE POVEPN( XPLAN, XPOINT,VDIR, IERR ) C ***************************************************************** C OBJET POVEPN : CALCULE UN POINT ET LA NORMALE DU PLAN C EN ENTREE : C XPLAN : EQUATION DU PLAN AX+BY+CZ+D = 0 C EN SORTIE : C XPOINT : UN POINT DU PLAN C VDIR : LE VECTEUR NORMAL AU PLAN C IERR : 0 SI OK, -1 SI "PLAN" N'EST PAS CORRECT C ***************************************************************** REAL XPLAN(3),XPOINT(2),VDIR(2) INTEGER IERR C INTEGER IDIMC IDIMC = 3 C --- NORMALE AU PLAN --- CALL COPIVE(XPLAN,IDIMC,VDIR) C --- CALCUL DU POINT --- CALL PODUPN(XPLAN,XPOINT,IERR) 9999 END C FUNCTION INPNDR(XPOINT,VDIR,XPLAN,ITEST,XPI,IERR) C ***************************************************************** C OBJET INPNDR : INTERSECTION D'UN PLAN ET D'UNE DROITE C EN ENTREE : C XPOINT : UN POINT DE LA DROITE C VDIR : LE VECTEUR DIRECTEUR DE LA DROITE C XPLAN : L'EQUATION DU PLAN : AX+BY+CZ+D = 0 C ITEST : SI ITEST=1 ON NE CALCULE PAS LA POSITION DU POINT C EN SORTIE : RENVOI 1 SI INTERSECTION 0 SINON C XPI : POSITION DU POINT D'INTERSECTION (SI ITEST=0) C IERR : 0 TOUJOURS OK C ***************************************************************** INTEGER INPNDR REAL XPOINT(3),VDIR(3),XPLAN(4) INTEGER ITEST,IERR REAL XPI(3) C COMMON /CGEPSI/ XYZHUG,XYZMIN,XYZEPS REAL XYZHUG,XYZMIN,XYZEPS C INTEGER I REAL ALPHA,XDENO,SCALVE EXTERNAL SCALVE C IERR = 0 C ======================== C --- TEST DE L'INTERSECTION --- C ======================== XDENO = SCALVE(XPLAN,VDIR,3) IF((XDENO.GT.-XYZEPS).AND.(XDENO.LT.XYZEPS))THEN C ---- LE VECTEUR EST DANS LE PLAN ---- INPNDR = 0 GOTO 9999 ENDIF INPNDR = 1 IF(ITEST.EQ.1)GOTO 9999 C ================================ C --- CALCUL DU POINT D'INTERSECTION --- C ================================ ALPHA = (SCALVE(XPLAN,XPOINT,3) + XPLAN(4)) C PRINT *,'VDIR =',(VDIR(I),I=1,3) C PRINT *,'ALPHA =',ALPHA C PRINT *,'XDENO =',XDENO ALPHA = -ALPHA / XDENO C ALPHA = (SCALVE(XPLAN,XPOINT,3) + XPLAN(4)) / XDENO C PRINT *,'ALPHA =',ALPHA CALL MUSCVE( VDIR, ALPHA, 3, XPI ) C PRINT *,'XPI =',(XPI(I),I=1,3) C PRINT *,'XPOINT =',(XPOINT(I),I=1,3) CALL SOMMVE( XPI, XPOINT, 3, XPI ) C PRINT *,'INTERSECTION PLAN =',XPI(1),XPI(2),XPI(3) C 9999 END C SUBROUTINE PL3PO_NEW( XP1,XP2,XP3, XPLAN, IERR ) C ***************************************************************** C OBJET PL3PO_NEW : CALCULE LE PLAN PASSANT PAR LES 3 POINTS C EN ENTREE: C XP1, XP2, XP3 : LES 3 POINTS DU PLAN C EN SORTIE C XPLAN : LES COEFFICIENTS A,B,C,D DE L'EQUATION DU PLAN C AX+BY+CZ+D = 0 C IERR : -1 SI XP1 ET XP2 SONT CONFONDUS, C SI XP1,XP2 ET XP3 ALIGNES, C 0 SINON C ***************************************************************** REAL XP1(3),XP2(3),XP3(3),XPLAN(4) INTEGER IERR C COMMON /CGEPSI/ XYZHUG,XYZMIN,XYZEPS REAL XYZHUG,XYZMIN,XYZEPS,XN,XNO REAL SCALVE EXTERNAL SCALVE C REAL COORD(9),XPLANO(4) INTEGER IPOINT(3),IDIMC,NPOINT,I,IND1,IND2 C CALL PL3PO( XP1,XP2,XP3, XPLANO, IERR ) IERR = 0 C IDIMC = 3 CALL COPIVE(XP1,IDIMC,COORD) CALL COPIVE(XP2,IDIMC,COORD(4)) CALL COPIVE(XP3,IDIMC,COORD(7)) NPOINT = 3 DO 10 I=1,NPOINT IPOINT(I) = I 10 CONTINUE C IND1 = 0 IND2 = 0 CALL PLMCAR(IPOINT,NPOINT,IND1,IND2,COORD,IDIMC,XPLAN,IERR) C C ---- POUR LE TEST ---- C DO 100 I=1,NPOINT XN = SCALVE(XPLAN,COORD((I-1)*IDIMC+1),IDIMC) + XPLAN(4) XNO = SCALVE(XPLANO,COORD((I-1)*IDIMC+1),IDIMC) + XPLANO(4) IF((XN.GT.XNO).OR.(XN.LT. -XNO))THEN PRINT *,'PL3PO OLDM = ',XNO,' NEW = ',XN ELSE IF((XNO.GT.XN).OR.(XNO.LT. -XN))THEN PRINT *,'PL3PO OLD = ',XNO,' NEWM = ',XN ELSE PRINT *,'PL3PO IDEM OLD = ',XNO,' NEW = ',XN ENDIF ENDIF 100 CONTINUE C PRINT *,'PL3PO : ',(XPLANO(I)-XPLAN(I),I=1,4) C 9999 END C SUBROUTINE PL3PO( XP1,XP2,XP3, XPLAN, IERR ) C ***************************************************************** C OBJET PL3PO : CALCULE LE PLAN PASSANT PAR LES 3 POINTS C EN ENTREE: C XP1, XP2, XP3 : LES 3 POINTS DU PLAN C EN SORTIE C XPLAN : LES COEFFICIENTS A,B,C,D DE L'EQUATION DU PLAN C AX+BY+CZ+D = 0 C IERR : -1 SI XP1 ET XP2 SONT CONFONDUS, C SI XP1,XP2 ET XP3 ALIGNES, C 0 SINON C ***************************************************************** REAL XP1(3),XP2(3),XP3(3),XPLAN(4) INTEGER IERR C COMMON /CGEPSI/ XYZHUG,XYZMIN,XYZEPS REAL XYZHUG,XYZMIN,XYZEPS C REAL XN,V12(3),V23(3),XP(3),ZERO REAL XNORVE,SCALVE EXTERNAL XNORVE,SCALVE INTEGER IDIMC,I PARAMETER ( ZERO = 1.E-3 ) C IDIMC = 3 CALL DIFFVE(XP1,XP2,IDIMC,V12) CALL DIFFVE(XP2,XP3,IDIMC,V23) CALL VECTVE(V12,V23,IDIMC,XPLAN) XN = XNORVE(XPLAN,IDIMC) IF((XN.LE.XYZEPS).AND.(XN.GE. -XYZEPS))THEN IERR = -1 CALL DSERRE(1,IERR,'PL3PO','POINTS ALIGNES ?') GOTO 9999 ENDIF XN = 1.0 / XN IERR = 0 CALL MUSCVE(XPLAN,XN,IDIMC,XPLAN) DO 10 I=1,IDIMC XP(I) = (XP1(I) + XP2(I) + XP3(I) ) / 3.0 10 CONTINUE XPLAN(4) = - SCALVE(XPLAN,XP,IDIMC) C C ---- POUR LE TEST ---- C XN = SCALVE(XPLAN,XP1,IDIMC) + XPLAN(4) IF((XN.GT.ZERO).OR.(XN.LT.-ZERO))THEN C PRINT *,'IL Y A UNE ERREUR DANS PL3PO XP1 ' C PRINT *,'XPLAN = ',(XPLAN(I),I=1,4) C PRINT *,'XP1 = ',(XP1(I),I=1,3) C PRINT *,'XPLAN * XP1 = ',XN IERR = -1 ENDIF XN = SCALVE(XPLAN,XP2,IDIMC) + XPLAN(4) IF((XN.GT.ZERO).OR.(XN.LT. -ZERO))THEN C PRINT *,'IL Y A UNE ERREUR DANS PL3PO XP2 ' C PRINT *,'XPLAN = ',(XPLAN(I),I=1,4) C PRINT *,'XP2 = ',(XP2(I),I=1,3) C PRINT *,'XPLAN * XP2 = ',XN IERR = -1 ENDIF XN = SCALVE(XPLAN,XP3,IDIMC) + XPLAN(4) IF((XN.GT.ZERO).OR.(XN.LT. -ZERO))THEN C PRINT *,'IL Y A UNE ERREUR DANS PL3PO XP3 ' C PRINT *,'XPLAN = ',(XPLAN(I),I=1,4) C PRINT *,'XP3 = ',(XP3(I),I=1,3) C PRINT *,'XPLAN * XP3 = ',XN IERR = -1 ENDIF IF(IERR.NE.0)CALL DSERRE(1,IERR,'PL3PO','CALCUL ERRONE') 9999 END C C SUBROUTINE PLMCAR(IPOINT,NPOINT,IND1,IND2,COORD,IDIMC,XPLAN,IERR) C ***************************************************************** C OBJET PLMCAR : CALCULE LE PLAN DES MOINDRES CARRES DE N POINTS C EN ENTREE: C ---- DEFINITION DES POINTS A TRAITER ---- C IPOINT : TABLEAU DES INDICES DES POINTS DANS COORD C NPOINT : NOMBRE DE POINTS C OU C IND1,IND2 : INDICE DU PREMIER ET DERNIER POINT A TRAITER C C COORD : COORDONNEES DES POINTS C C EN SORTIE C XPLAN : LES COEFFICIENTS A,B,C,D DE L'EQUATION DU PLAN C AX+BY+CZ+D = 0 C IERR : -1 SI SOLUTION PAS UNIQUE C 0 SINON C AUTEUR : SIDI-MOHAMED TIJANI C ***************************************************************** INTEGER NPOINT,IPOINT(*),IND1,IND2 REAL COORD(*) INTEGER IDIMC REAL XPLAN(*) INTEGER IERR C REAL G(3),S(3,3),C INTEGER I,J,L,NBPOI C NBPOI = NPOINT IF( NBPOI.LE.0 )NBPOI = IND2 - IND1 + 1 IF( NBPOI.LT.3 )THEN IERR = -1 CALL DSERRE(1,IERR,'PLMCAR',' IL FAUT 3 POINTS OU +') GOTO 9999 ENDIF IF( IDIMC.NE.3 )THEN IERR = -1 CALL DSERRE(1,IERR,'PLMCAR',' 3D SEULEMENT') GOTO 9999 ENDIF C = 0. C C ---- AVEC LA LISTE DE POINTS ---- IF( NPOINT.GT.0 )THEN DO 30 I=1,IDIMC G(I) = 0. DO 10 L=1,NPOINT G(I)=G(I)+COORD((IPOINT(L)-1)*IDIMC+I) 10 CONTINUE G(I)=G(I)/NPOINT DO 20 L=1,NPOINT C=MAX(C,ABS(G(I)-COORD((IPOINT(L)-1)*IDIMC+I))) 20 CONTINUE 30 CONTINUE C DO 60 I=1,IDIMC DO 50 J=1,I S(I,J)=0. DO 40 L=1,NPOINT S(I,J) = S(I,J) + > ((COORD((IPOINT(L)-1)*IDIMC+I)-G(I))/C) * > ((COORD((IPOINT(L)-1)*IDIMC+J)-G(J))/C) 40 CONTINUE S(I,J)=S(I,J)/NPOINT S(J,I)=S(I,J) 50 CONTINUE 60 CONTINUE ELSE C ---- IDEM MAIS AVEC L'INTERVALLE ---- DO 130 I=1,IDIMC G(I) = 0. DO 110 L=IND1,IND2 G(I)=G(I)+COORD((L-1)*IDIMC+I) 110 CONTINUE G(I)=G(I)/NBPOI DO 120 L=IND1,IND2 C=MAX(C,ABS(G(I)-COORD((L-1)*IDIMC+I))) 120 CONTINUE 130 CONTINUE C DO 160 I=1,IDIMC DO 150 J=1,I S(I,J)=0. DO 140 L=IND1,IND2 S(I,J) = S(I,J) + > ((COORD((L-1)*IDIMC+I)-G(I))/C) * > ((COORD((L-1)*IDIMC+J)-G(J))/C) 140 CONTINUE S(I,J)=S(I,J)/NBPOI S(J,I)=S(I,J) 150 CONTINUE 160 CONTINUE ENDIF C CALL PRONUL(S,XPLAN) XPLAN(4)=-(XPLAN(1)*G(1)+XPLAN(2)*G(2)+XPLAN(3)*G(3)) C IERR = 0 9999 END C SUBROUTINE PRONUL(S,A) C ***************************************************************** C OBJET PRONUL : CALCUL LA VALEUR PROPRE NULLE DE LA MATRICE S. C DONNEE : S(3,3) EST UNE MATRICE SYMETRIQUE POSITIVE/NEGATIVE C (C.A.D. : VALEURS PROPRES DE MEME SIGNE). C RESULTAT : A(3) EST UN VECTEUR NORME ASSOCIE A C LA VALEUR PROPRE NULLE DE LA MATRICE S. C C AUTEUR : SIDI-MOHAMED TIJANI C ***************************************************************** REAL S(3,3) REAL A(3) C REAL D,DIV,DELTA,ADELTA,B INTEGER N(3),L,I,J,K DATA N /2,3,1/ C D=0. L=0 DO 10 I=1,3 J=N(I) K=N(J) DELTA=S(J,J)*S(K,K)-S(J,K)**2 ADELTA=ABS(DELTA) IF(ADELTA.LE.D) GOTO 10 L=I D=ADELTA DIV=DELTA 10 CONTINUE IF(D.GT.0.) GOTO 30 D=0. L=0 DO 20 I=1,3 A(I)=0. DELTA=ABS(S(I,I)) IF(DELTA.LE.D) GOTO 20 L=I D=DELTA 20 CONTINUE IF(D.LE.0.) THEN A(1)=1. RETURN ENDIF IF(L.EQ.1) THEN A(1)=-S(3,1)/S(1,1) A(3)=1. GOTO 40 ENDIF IF(L.EQ.3) THEN A(1)=1. A(3)=-S(1,3)/S(3,3) GOTO 40 ENDIF A(1)=1. A(3)=1. A(2)=(-S(1,2)-S(3,2))/S(2,2) 30 J=N(L) K=N(J) A(L)=DIV A(J)=S(L,K)*S(J,K)-S(K,K)*S(L,J) A(K)=S(J,K)*S(L,J)-S(J,J)*S(L,K) 40 B=SQRT(A(1)*A(1)+A(2)*A(2)+A(3)*A(3)) IF(B.NE.0.) THEN A(1)=A(1)/B A(2)=A(2)/B A(3)=A(3)/B ENDIF RETURN END C C SUBROUTINE RPPNCR(IPOINT,NPOINT,IND1,IND2, > COORD,IDIMC, > ITVL,ITVMAX,RTVL,IRTMAX, > O,XMATT,COORD2,IDIMC2,IERR) C ***************************************************************** C OBJET RPPNCR : PASSAGE DANS LE REPERE DU PLAN DES MOINDRES CARRES C EN ENTREE : C ----- UNE LISTE DE POINTS OU UN INTERVAL ----- C IPOINT : LA LISTE DES POINTS A TRAITER C NPOINT : NOMBRE DE POINTS DANS LA LISTE C IND1,IND2 : INDICE DU PREMIER POINT, ET DU DERNIER C C EN SORTIE : C COORD2 : NOUVELLES COORDONNEES (SI IDIMC2 > 0) C EST REMPLI DE 1 A NBPOINT (OU IND2-IND1+1) C O : NOUVELLE ORIGINE C MATT : MATRICE 3x3 DE PASSAGE DANS LE NOUVEAU REPERE C ***************************************************************** INTEGER IPOINT(*),NPOINT,IND1,IND2 REAL COORD(*) INTEGER IDIMC,ITVL(*),ITVMAX,IRTMAX REAL RTVL(*) REAL O(3),XMATT(3,3),COORD2(*) INTEGER IDIMC2,IERR C REAL SCALVE EXTERNAL SCALVE REAL XPLAN(4),YMATT(3,3),XPOINT(3),XLGCOL INTEGER I,II,J,K,NBNUN,NBPOI REAL ZERO PARAMETER (ZERO=1.E-7) C CALL PLMCAR(IPOINT,NPOINT,IND1,IND2,COORD,IDIMC,XPLAN,IERR) IF( IERR.NE.0 )THEN CALL DSERRE(1,IERR,'RPPNCR','APPEL PLMCAR') GOTO 9999 ENDIF C --- MODIF : 09.09.99 O.STAB POUR EVITER L'UNDERFLOW SUR SUN DANS M33INV C C'est pas grave si on ne projete pas dans le plan exact !!! C A TESTER ET PASSER ZERO EN COMMON !!!! DO 5 I=1,4 IF((XPLAN(I).LT.ZERO).AND.(XPLAN(I).GT.-ZERO))XPLAN(I) = 0.0 5 CONTINUE C CALL M33DPN(XPLAN,YMATT(1,1),YMATT(1,2),YMATT(1,3),IERR) IF( IERR.NE.0 )THEN CALL DSERRE(1,IERR,'RPPNCR','APPEL M33DPN') GOTO 9999 ENDIF C CALL M33INV(YMATT,XMATT,IERR) IF( IERR.NE. 0 )THEN CALL DSERRE(1,IERR,'RPPNCR','APPEL M33INV') GOTO 9999 ENDIF C CALL PODUPN( XPLAN, O, IERR ) IF( IERR.NE. 0 )THEN CALL DSERRE(1,IERR,'RPPNCR','APPEL PODUPN') GOTO 9999 ENDIF C IF( IDIMC2.LE.0 )GOTO 9999 NBNUN = 1 NBPOI = MAX(NPOINT,IND2-IND1+1) DO 100 I=1,NBPOI II = I+IND1-1 IF( NPOINT.GT.0 )II = IPOINT(I) CALL COPIVE(COORD((II-1)*IDIMC+1),IDIMC,XPOINT) CALL DIFFVE(XPOINT,O,IDIMC,XPOINT) DO 20 J=1,IDIMC2 XLGCOL = XMATT(J,1)*XPOINT(1) DO 10 K=2,IDIMC XLGCOL = XMATT(J,K)*XPOINT(K) + XLGCOL 10 CONTINUE COORD2((I-1)*IDIMC2+J)= XLGCOL 20 CONTINUE 100 CONTINUE C 9999 END C C ***************************************************************** C MODULE : CG (CALCUL GEOMETRIQUE) C FICHIER : CG_REPERE.F C OBJET : CALCUL POUR LA GEOMETRIE 3D C FONCT. : C OBJET M33MUL : MULTIPLICATION DE MATRICES 3*3 C OBJET M33INV : INVERSION D'UNE MATRICE 3*3 C OBJET M33DET : DETERMINANT D'UNE MATRICE 3*3 C OBJET M33APP : APPLIQUE UNE TRANSFORMATION A X C ***************************************************************** C SUBROUTINE M33MUL(MAT1,MAT2,MAT3,IERR) C ****************************************************** C OBJET M33MUL : MULTIPLICATION DE MATRICES 3*3 C ****************************************************** REAL MAT1(3,*),MAT2(3,*),MAT3(3,*) INTEGER IERR C INTEGER I,J,K C DO 20 I=1,3 DO 10 J = 1,3 MAT3(I,J) = 0.0 DO 5 K = 1,3 MAT3(I,J) = MAT1(J,K) * MAT2(K,I) + MAT3(I,J) 5 CONTINUE 10 CONTINUE 20 CONTINUE 9999 END C C SUBROUTINE M33INV(MAT,MATINV,IERR) C ****************************************************** C OBJET M33INV : INVERSION D'UNE MATRICE 3*3 C ****************************************************** REAL MAT(3,*),MATINV(3,*) INTEGER IERR C REAL MATDET,MATEMP(3,3) INTEGER I,J REAL ZERO PARAMETER (ZERO = 1.E-6) C CALL M33DET(MAT,MATDET) IF( MATDET.LT. ZERO )THEN IERR = -1 GOTO 9999 ENDIF DO 20 I=1,3 DO 10 J = 1,3 MATEMP(I,J) = MAT(J,I) / MATDET 10 CONTINUE 20 CONTINUE C ---- VERIFICATION --- C CALL M33MUL(MATEMP,MAT,MATINV,IERR) C PRINT *,'M33INV : MAT*MATINV = ID ' C DO 100 I=1,3 C PRINT *,(MATINV(I,J),J=1,3) C 100 CONTINUE C DO 40 I=1,3 DO 30 J = 1,3 MATINV(I,J) = MATEMP(I,J) 30 CONTINUE 40 CONTINUE 9999 END C C SUBROUTINE M33DET(MAT,MATDET) C ****************************************************** C OBJET M33DET : DETERMINANT D'UNE MATRICE 3*3 C ****************************************************** REAL MAT(3,*),MATDET C MATDET = MAT(1,1) * (MAT(2,2)*MAT(3,3) - MAT(3,2)*MAT(2,3)) + > MAT(1,2) * (MAT(2,3)*MAT(3,1) - MAT(3,3)*MAT(2,1)) + > MAT(1,3) * (MAT(2,1)*MAT(3,2) - MAT(3,1)*MAT(2,2)) 9999 END C C SUBROUTINE M33APP(MAT,X,IDIMC,NBN,YT,Y) C ****************************************************** C OBJET M33APP : APPLIQUE UNE TRANSFORMATION A X C C X ET Y PEUVENT ETRE LES MEMES TABLEAUX C YT TABLEAU DE TRAVAIL DE TAILLE IDIMC C ****************************************************** REAL MAT(3,*),X(3,*) INTEGER IDIMC,NBN REAL YT(*),Y(3,*) C INTEGER I,J,K C DO 30 I=1,NBN DO 10 J=1,IDIMC YT(J) = 0.0 DO 5 K=1,IDIMC YT(J) = YT(J) + MAT(J,K)*X(K,I) 5 CONTINUE 10 CONTINUE DO 20 J=1,IDIMC Y(J,I) = YT(J) 20 CONTINUE 30 CONTINUE 9999 END C C ***************************************************************** C MODULE : ES (ENTREES SORTIES) C FICHIER : ES_ERREUR.F C OBJET : GESTION DES ERREURS ET AUTRES UTILITAIRES GENERAUX C C FONCT. : C OBJET DSINIT : INITIALISATION DES CONSTANTES DE DELOS (OBSOLET) C OBJET DSINIT2 : INITIALISATION DES CONSTANTES DE DELOS C OBJET DSERRE : ECRIT UN MESSAGE D'ERREUR (EN MODE DEBUG) C C AUTEUR : O.STAB C DATE : 02.96 / 05.96 C MODIFICATIONS : C AUTEUR, DATE, OBJET : O.STAB, 05.11.04, ajout du mode DEBUG C C C ***************************************************************** C SUBROUTINE DSINIT C ***************************************************************** C OBJET DSINIT : INITIALISATION DES CONSTANTES DE DELOS (OBSOLET) C C DOIT ETRE APPELE DE LE DEBUT DU PROGRAMME PRINCIPAL C C ***************************************************************** INTEGER IMODE COMMON /MODINI/IMODE IMODE = 2 CALL ICGEPS CALL STINIT END C C SUBROUTINE DSINIT2(ITRACE) C ***************************************************************** C OBJET DSINIT2 : INITIALISATION DES CONSTANTES DE DELOS C C DOIT ETRE APPELE DE LE DEBUT DU PROGRAMME PRINCIPAL C C ***************************************************************** INTEGER ITRACE INTEGER IMODE COMMON /MODINI/IMODE IMODE = ITRACE CALL ICGEPS CALL STINIT END C FUNCTION IDSLEN(CHAINE) C ***************************************************************** C OBJET IDSLEN : RENVOI LA LONGUEUR D'UNE CHAINE C ***************************************************************** INTEGER IDSLEN CHARACTER*(*) CHAINE C INTEGER I,J,LCH C LCH = LEN(CHAINE) J = LCH DO 10 I=1,LCH IF( CHAINE(J:J).NE.' ' )GOTO 888 J = J - 1 10 CONTINUE 888 IDSLEN = J C 999 END C C SUBROUTINE DSCHAI(IO,LABEL,NOM) C ***************************************************************** C OBJET DSCHAI : ECRIT UNE CHAINE SUR LE STANDARD OUTPUT C ***************************************************************** CHARACTER*(*) NOM,LABEL INTEGER IO C INTEGER IECR PARAMETER (IECR = 6) INTEGER IDSLEN EXTERNAL IDSLEN C IF( IO.EQ. 1 )THEN C --- STANDARD INPUT --- WRITE ( UNIT = IECR, FMT = *, ERR = 999) > LABEL(:IDSLEN(LABEL)),NOM(:IDSLEN(NOM)) ELSE IF( IO .EQ. 2 )THEN C --- ECRITURE DANS UN FICHIER ESPION --- WRITE ( UNIT = IECR, FMT = *) 'NON ENCORE IMPLEMENTE' ELSE IF( IO.EQ. 3 )THEN C --- AFFICHAGE VIA INTERFACE GRAPHIQUE --- WRITE ( UNIT = IECR, FMT = *) 'NON ENCORE IMPLEMENTE' ENDIF ENDIF ENDIF C 10 FORMAT(A) 999 END C C SUBROUTINE DSERRE(IO,NUM,MODULE,MESSAG) C ***************************************************************** C OBJET DSERRE : ECRIT UN MESSAGE D'ERREUR (EN MODE DEBUG) C SUR LE STANDARD OUTPUT C ***************************************************************** CHARACTER*(*) MESSAG,MODULE INTEGER NUM INTEGER IO C INTEGER IMODE COMMON /MODINI/IMODE IF(IMODE.LT.2)GOTO 9999 C IF( NUM .EQ. -1 )THEN CALL DSCHAI(IO, > 'ERR -1 DONNEES INCORRECTES DANS :',MODULE) ELSE IF( NUM .EQ. -2 )THEN CALL DSCHAI(IO, > 'ERR -2 PROBLEME MEMOIRE DANS :',MODULE) ELSE IF( NUM .EQ. -3 )THEN CALL DSCHAI(IO, > 'ERR -3 NON ENCORE IMPLEMENTE DANS :',MODULE) ELSE PRINT *,NUM ENDIF ENDIF ENDIF CALL DSCHAI(IO,MESSAG,' ') 9999 END C C ***************************************************************** C MODULE : ST (STRUCTURE DES DONNEES) C FICHIER : ST_ENSEMBLE.F C OBJET : MANIPULATION DES ENSEMBLES C FONCT. : C ENSTRI : TRI UN TABLEAU D'ENTIER DANS L'ORDRE CROISSANT C ENSCP : COPIE UN TABLEAU D'ENTIER DANS UN AUTRE C C OPERATIONS BOOLEENNES SUR DES ENSEMBLES C ENSUNI : FAIT L'UNION ENTRE 2 TABLEAUX TRIES (CF ENSTRI) C ENSINT : FAIT L'INTERSECTION ENTRE 2 TABLEAUX TRIES (CF ENSTRI) C ENSDIF : FAIT LA DIFFERENCE ENTRE 2 TABLEAUX TRIES (CF ENSTRI) C C AUTEUR : O. STAB C DATE : 03.95 C MODIFICATIONS : C AUTEUR, DATE, OBJET : C C C ***************************************************************** C SUBROUTINE ENSTRI(ITAB1,NB1) C ***************************************************** C OBJET ENSTRI : TRI UN TABLEAU D'ENTIER DANS L'ORDRE CROISSANT C EN ENTREE: C ITAB1 : TABLEAU A ORDONNER C NB1 : CARDINAL DE NB1 C EN SORTIE : C IATB1 : TRIE C ****************************************************** INTEGER ITAB1(*), NB1 C CALL KNUTA(NB1,ITAB1) END C SUBROUTINE ENSCP(ITAB1,NB1,ITAB2,NB2) C ***************************************************** C OBJET ENSCP : COPIE D'UN TABLEAU D'ENTIER C EN ENTREE: C ITAB1 : TABLEAU A COPIER C NB1 : CARDINAL DE NB1 C EN SORIE : C ITAB2 : COPIE DE ITAB1 C NB2 : CARDINAL DE NB2 (=NB1) C ****************************************************** INTEGER ITAB1(NB1), NB1, ITAB2(NB1), NB2 C INTEGER I C DO 10 I=1,NB1 ITAB2(I) = ITAB1(I) 10 CONTINUE NB2 = NB1 END C C SUBROUTINE ENSAJO(ITAB1,NB1,ITAB2,NB2) C ***************************************************** C OBJET ENSAJO : COPIE UN TABLEAU D'ENTIER DANS UN AUTRE C EN ENTREE: C ITAB1 : TABLEAU A COPIER C NB1 : CARDINAL DE NB1 C EN SORIE : C ITAB2 : CONCATENATION ITAB2+ITAB1 C NB2 : CARDINAL DE NB2 (=NB1+NB2) C ****************************************************** INTEGER ITAB1(NB1), NB1, ITAB2(NB1), NB2 C INTEGER I C DO 10 I=1,NB1 ITAB2(I+NB2) = ITAB1(I) 10 CONTINUE NB2 = NB1+NB2 END C C SUBROUTINE ENCOMP(ITAB1,NB1,NB2) C ***************************************************** C OBJET ENCOMP : COMPRIME UN TABLEAU D'ENTIER (SUPPRIME LES DOUBLONS) C EN ENTREE: C ITAB1 : TABLEAU C NB1 : CARDINAL DE NB1 C EN SORIE : C ITAB1 : TABLEAU COMPRIME (ET TRIE) C NB2 : CARDINAL DE NB2 ( =< NB1) C ****************************************************** INTEGER ITAB1(NB1), NB1, NB2 C INTEGER I,J C CALL KNUTA(NB1,ITAB1) J = 1 DO 10 I=2,NB1 IF( ITAB1(J).EQ. ITAB1(I))GOTO 10 J = J + 1 ITAB1(J) = ITAB1(I) 10 CONTINUE NB2 = J END C SUBROUTINE ENSUNI(ITAB1,NB1,ITAB2,NB2,ITAB3,NB3MAX,NB3,IERR) C *********************************************************** C OBJET : FAIT L'UNION ENTRE 2 TABLEAUX TRIES (CF ENSTRI) C EN ENTREE: C ITAB1,TAB2 : TABLEAUX C NB1 ,NB2 : CARDINAUX RESPECTIFS C NB3MAX : TAILLE DU TABLEAU ITAB3 C EN SORTIE : C ITAB3 : ITAB1 U ITAB2 (LE TABLEAU EST TRIE) C NB3 : CARDINAL DE ITAB1 U ITAB3 C IERR : CODE D'ERREUR 0 => OK, C -N => MANQUE N CASES A ITAB3 C *********************************************************** INTEGER ITAB1(NB1),ITAB2(NB2),ITAB3(NB3MAX) INTEGER NB1,NB2,NB3,NB3MAX,IERR C INTEGER I,J,II,JJ C I=1 J=1 NB3=0 IERR = 0 10 IF( J .GT. NB2 )THEN DO 20 II=I,NB1 NB3 = NB3 + 1 IF( NB3 .LE. NB3MAX )ITAB3(NB3) = ITAB1(II) 20 CONTINUE IF( NB3 .GT. NB3MAX )IERR = NB3 - NB3MAX GOTO 999 ENDIF C IF( I .GT. NB1 )THEN DO 30 JJ=J,NB2 NB3 = NB3 + 1 IF( NB3 .LE. NB3MAX)ITAB3(NB3) = ITAB2(JJ) 30 CONTINUE IF( NB3 .GT. NB3MAX )IERR = NB3 - NB3MAX GOTO 999 ENDIF C NB3 = NB3 + 1 IF(ITAB1(I) .GT. ITAB2(J))THEN IF( NB3 .LE. NB3MAX)ITAB3(NB3) = ITAB2(J) J = J + 1 ELSE IF(ITAB1(I) .LT. ITAB2(J))THEN IF( NB3 .LE. NB3MAX)ITAB3(NB3) = ITAB1(I) I = I + 1 ELSE IF( NB3 .LE. NB3MAX)ITAB3(NB3) = ITAB1(I) I = I + 1 J = J + 1 ENDIF ENDIF GO TO 10 999 END C SUBROUTINE ENSINT(ITAB1,NB1,ITAB2,NB2,ITAB3,NB3MAX,NB3,IERR) C *********************************************************** C OBJET : FAIT L'INTERSECTION ENTRE 2 TABLEAUX TRIES (CF ENSTRI) C EN ENTREE: C ITAB1,TAB2 : TABLEAUX C NB1 ,NB2 : CARDINAUX RESPECTIFS C NB3MAX : TAILLE DU TABLEAU ITAB3 C EN SORTIE : C ITAB3 : ITAB1 N ITAB2 (LE TABLEAU EST TRIE) C NB3 : CARDINAL DE ITAB1 N ITAB3 C IERR : CODE D'ERREUR 0 => OK, C -N => MANQUE N CASES A ITAB3 C *********************************************************** INTEGER ITAB1(NB1), ITAB2(NB2), ITAB3(NB3MAX) INTEGER NB3MAX, NB1, NB2, NB3, IERR C INTEGER I,J C I=1 J=1 NB3=0 IERR = 0 10 IF(( J .GT. NB2 ) .OR. ( I .GT. NB1 ))GO TO 999 IF(ITAB1(I) .GT. ITAB2(J))THEN J = J + 1 ELSE IF(ITAB1(I) .LT. ITAB2(J))THEN I = I + 1 ELSE NB3 = NB3 + 1 IF( NB3 .LE. NB3MAX)ITAB3(NB3) = ITAB1(I) I = I + 1 J = J + 1 ENDIF GO TO 10 999 END C C SUBROUTINE ENSDIF(ITAB1,NB1,ITAB2,NB2,ITAB3,NB3MAX,NB3,IERR) C *********************************************************** C OBJET : FAIT LA DIFFERENCE ENTRE 2 TABLEAUX TRIES (CF ENSTRI) C EN ENTREE: C ITAB1,TAB2 : TABLEAUX C NB1 ,NB2 : CARDINAUX RESPECTIFS C NB3MAX : TAILLE DU TABLEAU ITAB3 C EN SORTIE : C ITAB3 : ITAB1 - ITAB2 (LE TABLEAU EST TRIE) C NB3 : CARDINAL DE ITAB1 - ITAB3 C IERR : CODE D'ERREUR 0 => OK, C -N => MANQUE N CASES A ITAB3 C *********************************************************** INTEGER ITAB1(NB1), ITAB2(NB2), ITAB3(NB3MAX) INTEGER NB3MAX, NB1, NB2, NB3, IERR C INTEGER I,J,II C I=1 J=1 NB3=0 IERR = 0 10 IF( J .GT. NB2 )THEN DO 20 II=I,NB1 NB3 = NB3 + 1 IF( NB3 .LE. NB3MAX)ITAB3(NB3) = ITAB1(II) 20 CONTINUE IF( NB3 .GT. NB3MAX)IERR = NB3-NB3MAX GOTO 999 ENDIF IF( I .GT. NB1 )GO TO 999 IF(ITAB1(I) .GT. ITAB2(J))THEN J = J + 1 ELSE IF(ITAB1(I) .LT. ITAB2(J))THEN NB3 = NB3 + 1 IF( NB3 .LE. NB3MAX)ITAB3(NB3) = ITAB1(I) I = I + 1 ELSE I = I + 1 J = J + 1 ENDIF GO TO 10 999 END C C ********************************************************************** C MODULE : ST C FICHIER : ST_SPH.F C OBJET : UTILITAIRES POUR LA GESTION DES SPHERES CIRCONSCRITES C FONCT. : C SPPERM : PERMUTE 2 ELEMENTS D'UN TABLEAU C SPCOMP : RENUMEROTE LES ELEMENTS D'UN TABLEAU POUR LES COMPACTER C EN DEBUT : DE 1 A "NBNUM" C C AUTEUR : O. STAB C DATE : 03.95 C MODIFICATIONS : C AUTEUR, DATE, OBJET : C C C ********************************************************************** C SUBROUTINE SPPERM(TAB,NBNMAX,NBE,IT1,IT2,IERR) C ********************************************************************** C OBJET : PERMUTE 2 ELEMENTS D'UN TABLEAU C EN ENTREE: C ITAB : TABLEAU DES ELEMENTS C NBCMAX : (2..6) NOMBRE DE COTES MAXIMUM DES ELEMENTS C NBE : NOMBRE D'ELEMENTS DU MAILLAGE C ITL,IT2: LES 2 ELEMENTS A PERMUTER C EN SORTIE: C ********************************************************************** REAL TAB(*) INTEGER NBNMAX,NBE INTEGER IT1, IT2, IERR C INTEGER I REAL TAMPON(4) C IF( IT1 .EQ. IT2 )GO TO 999 IF((IT1.LT.1).OR.(IT1.GT.NBE).OR. > (IT2.LT.1).OR.(IT2.GT.NBE))THEN IERR = -1 GO TO 999 ENDIF C ------------------ SAUVEGARDE IT2 --- DO 10 I=1,NBNMAX TAMPON(I)=TAB((IT2-1)*NBNMAX+I) 10 CONTINUE C ---------- TRANSFERT IT1 -> IT2 ---------- DO 20 I=1,NBNMAX TAB((IT2-1)*NBNMAX+I)=TAB((IT1-1)*NBNMAX+I) 20 CONTINUE C ---------- TRANSFERT IT2 -> IT1 ---------- DO 30 I=1,NBNMAX TAB((IT1-1)*NBNMAX+I)=TAMPON(I) 30 CONTINUE C ------------------ 999 END C SUBROUTINE SPCOMP(TAB,NBCOL,NBLIG,NUM,NBNUM,IERR) C ********************************************************************** C OBJET : RENUMEROTE LES ELEMENTS D'UN TABLEAU POUR LES COMPACTER C EN DEBUT : DE 1 A "NBNUM" C EN ENTREE: C NUM : NUM(I) EST NUMERO DE L'ELEMENT QUI DOIT ETRE MIS EN I C ATTENTION !! NUM DOIT ETRE TRIE AVEC ENSTRI C NBNUM : NOMBRE D'ELEMENTS A RENUMEROTER C EN SORTIE: C COMPLEXITE : O(NBNUM) C PRINCIPE : LES PERMUTATIONS FONCTIONNENT SI NUM(I)>I C C.A.D. L'ANCIENNE POSITION > A LA NOUVELLE C ON EST DANS CE CAS SI NUM EST TRIE PAR ORDRE CROISS. C ********************************************************************** REAL TAB(*) INTEGER NBCOL,NBLIG INTEGER NUM(*),NBNUM,IERR C INTEGER I C DO 10 I=1,NBNUM CALL SPPERM(TAB,NBCOL,NBLIG,NUM(I),I,IERR) 10 CONTINUE END C C ******************************************************************* C FICHIER : ST_EVAL.F C OBJET : EVALUATION DES MAILLAGES 1D 2D ET 3D C C FONCT. : C OBJET STTTPG : ECRIT UN MAILLAGE SOUS FORME DE PROGRAMME FORTRAN C OBJET EVFCTT : MIN,MAX,SOMME D'UNE FONCTION SUR UN MAILLAGE C C AUTEUR : O. STAB C DATE : 07.95 C TESTS : 07.95 C MODIFICATIONS : C AUTEUR, DATE, OBJET : O.STAB, 08.97, RESTRUCTURATION C AUTEUR, DATE, OBJET : O.STAB, 10.97, INTEGRATION V.2.0.0 C AUTEUR, DATE, OBJET : O.STAB, 11.97, RESTRUCTURATION C C C ******************************************************************* C SUBROUTINE STTTPG(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,NOEMAX, > COORD,IDIMC,NBN,NBE,IERR) C ***************************************************************** C OBJET STTTPG : ECRIT UN MAILLAGE SOUS FORME DE PROGRAMME FORTRAN C EN ENTREE C --------- LE MAILLAGE --------------------- C ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,NOEMAX,NBN,NBE : LE MAILLAGE C COORD,IDIMC: LES COORDONNEES DES NOEUDS C C EN SORTIE : UNE EVALUATION C IERR : CODE D'ERREUR C -1 TOUS LES POINTS N'ONT PAS PU ETRE AJOUTES C -2 ITVL OU RTVL TROP PETIT C REMARQUES : C ********************************************************************** INTEGER IDE,NBE,ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX INTEGER IDIMC,NOETRI(*),NOEMAX,NBN,IERR REAL COORD(*),R C INTEGER I,J INTEGER IP,IX INTEGER ICLAV,IECR PARAMETER (ICLAV = 5, IECR = 6) C IF( NBE.LE. 0 )GOTO 9999 R = 1. / 15. C WRITE(UNIT = IECR, FMT = '(A)') >' SUBROUTINE T3IXXX(IDE,IDIMC,R,COORD,' WRITE(UNIT = IECR, FMT = '(A)') >' > ITRNOE,NBNMAX,ITRTRI,NBCMAX,' WRITE(UNIT = IECR, FMT = '(A)') >' > NOETRI,NOEMAX,NBN,NBE)' WRITE(UNIT = IECR, FMT = '(A)') >'C **********************************************' WRITE(UNIT = IECR, FMT = '(A)') >'C OBJET : MAILLAGE EN DUR ' WRITE(UNIT = IECR, FMT = '(A)') >'C A TOPOLOGIE CONSTANTE ' WRITE(UNIT = IECR, FMT = '(A)') >'C **********************************************' C WRITE(UNIT = IECR, FMT = '(A)') >' INTEGER IDE,IDIMC,ITRNOE(*),NBNMAX,ITRTRI(*)' WRITE(UNIT = IECR, FMT = '(A)') >' INTEGER NBCMAX,NBE,NBN,NOETRI(*),NOEMAX' WRITE(UNIT = IECR, FMT = '(A)') >' REAL R,COORD(*)' C WRITE(UNIT = IECR, FMT = *) >' IDE = ',IDE WRITE(UNIT = IECR, FMT = *) >' NBNMAX = ',NBNMAX WRITE(UNIT = IECR, FMT = *) >' NBCMAX = ',NBCMAX WRITE(UNIT = IECR, FMT = *) >' NBN = ',NBN WRITE(UNIT = IECR, FMT = *) >' NBE = ',NBE WRITE(UNIT = IECR, FMT = '(A)') >'C ---- LES COORDONNEES DES NOEUDS ----' DO 5 I=1,NBN DO 4 J=1,IDIMC IX = (I-1)*IDIMC+J WRITE(UNIT = IECR, FMT = *) > ' COORD(',IX,') =',COORD(IX)*R,'*R' 4 CONTINUE 5 CONTINUE WRITE(UNIT = IECR, FMT = '(A)') >'C ---- LES TETRA INCIDENTS AUX NOEUDS ----' DO 30 I=1,NBE DO 10 J=1,NBNMAX IP = (I-1)*NBNMAX+J WRITE(UNIT = IECR, FMT = *) > ' ITRNOE(',IP,') = ',ITRNOE(IP) 10 CONTINUE DO 20 J=1,NBCMAX IP = (I-1)*NBCMAX+J WRITE(UNIT = IECR, FMT = *) > ' ITRTRI(',IP,') = ',ITRTRI(IP) 20 CONTINUE 30 CONTINUE WRITE(UNIT = IECR, FMT = '(A)') >'C ---- LES TETRA INCIDENTS AUX NOEUDS ----' WRITE(UNIT = IECR, FMT = '(A)') >' IF(NOEMAX.LT.NBN)GOTO 9999' DO 40 I=1,NBN WRITE(UNIT = IECR, FMT = *) > ' NOETRI(',I,') =',NOETRI(I) 40 CONTINUE WRITE(UNIT = IECR, FMT = '(A)') >'C ' WRITE(UNIT = IECR, FMT = '(A)') >' 9999 END' C C 9999 END C SUBROUTINE EVFCTT(ITRNOE,NBNMAX,FCVAL, > COORD,IDIMC,NBN,NBE, > VALMIN,VALMAX,NBEINT, > RMINI,IMINI,RMAXI,IMAXI,RTOTA,IERR) C ***************************************************************** C OBJET EVFCTT : MIN,MAX,SOMME D'UNE FONCTION SUR UN MAILLAGE C EN ENTREE C VALMIN,VALMAX : VALEUR MINIMUM ET MAXIMUM DE L'INTERVAL C FCVAL : FONCTION DE 4 PARAMETRES C + LES COORDONNEES DES NBNMAX POINTS DE L'ELEMENT C + DIMENSION DE L'ESPACE C C EN SORTIE : C NBEINT: NOMBRE D'ELEMENTS DANS L'INTERVALLE C RMINI : VALEUR MINIMUM C IMINI : INDICE DE L'ELEMENT DE VALEUR MINIMUM C RMAXI : VALEUR MAXIMUM C IMAXI : INDICE DE L'ELEMENT DE VALEUR MAXIMUM C RTOTA : TOTAL DES VALEUR C C REMARQUES : C ********************************************************************** INTEGER ITRNOE(*),NBNMAX INTEGER IDIMC,NBN,NBE,IERR REAL COORD(*) REAL VALMIN,VALMAX INTEGER NBEINT,IMINI,IMAXI REAL RMINI,RMAXI,RTOTA C INTEGER I,J,IP(4) REAL VAL,FCVAL EXTERNAL FCVAL C RTOTA = 0.0 RMAXI = -1.0 RMINI = 1.0e38 NBEINT = 0 C DO 120 I=1,NBE C ============ C ---- CALCUL FCVAL ---- C ============ C DO 10 J=1,NBNMAX IP(J) = (ITRNOE((I-1)*NBNMAX+J)-1)*IDIMC+1 10 CONTINUE C GOTO (20,30,40,50,60,70,80) NBNMAX C C --- NBNMAX = 0 : IMPOSSIBLE -------- C ------------------------------- IERR = -1 CALL DSERRE(1,IERR,'EVFCTT','ELEMENTS SANS NOEUDS') GOTO 9999 C C --- NBNMAX = 1 : ELEMENTS = NOEUDS ------------ C ------------------------------- 20 CONTINUE VAL = FCVAL(COORD(IP(1)),IDIMC) GOTO 100 C C --- NBNMAX = 2 : ELEMENTS = SEGMENTS ------------ C ------------------------------- 30 CONTINUE VAL = FCVAL(COORD(IP(1)),COORD(IP(2)),IDIMC) GOTO 100 C C --- NBNMAX = 3 : ELEMENTS = TRIANGLES ------------ C ------------------------------- 40 CONTINUE VAL = FCVAL(COORD(IP(1)),COORD(IP(2)), > COORD(IP(3)),IDIMC) GOTO 100 C C C --- NBNMAX = 4 : ELEMENTS = TETRA OU QUADRANGLES ------------ C ---------------------------------------------- 50 CONTINUE C --- COMME ON EST EN 3D LA DIMENSION NE SERT A RIEN C MAIS ON POURRAIT UNIFORMISER :NECESSAIRE POUR C DISTINGUER TETRA ET QUADRANGLES C VAL = FCVAL(COORD(IP(1)),COORD(IP(2)), > COORD(IP(3)),COORD(IP(4))) GOTO 100 C C --- NBNMAX = 5,6,8 : ELEMENTS = PYRAM, PRISME, HEXA ------------ C ------------------------------- 60 CONTINUE 70 CONTINUE 80 CONTINUE IERR = -3 GOTO 9999 C ------------------------------------------------ 100 CONTINUE RTOTA = RTOTA + VAL IF(( VAL.GT.VALMIN ).AND.( VAL.LT.VALMAX ))THEN NBEINT = NBEINT+1 ENDIF C IF( VAL.LT. RMINI )THEN RMINI = VAL IMINI = I ENDIF IF( VAL.GT. RMAXI )THEN RMAXI = VAL IMAXI = I ENDIF 120 CONTINUE C 9999 END C C ***************************************************************** C MODULE : ST (STRUCTURE DES DONNEES) C FICHIER : GEOMETRIE.F C OBJET : CALCULS GEOMETRIQUES ELEMENTAIRES SUR LES ELEMENTS C D'UN MAILLAGE C FONCT. : C GTAILL : CALCULE LA TAILLE D'UN SIMPLEX C GORIEN : RENVOI L'ORIENTATION DE L'ELEMENT C GBARYC : CALCULE LE BARYCENTRE D'UN SIMPLEXE C C AUTEUR : O. STAB C DATE : 03.95 C TESTS : PARTIELS C MODIFICATIONS : C AUTEUR, DATE, OBJET : C C REMARQUE : ---- A REPRENDRE AVEC LA LOGIQUE SUIVANTE ---- C LA FONCTION LA PLUS BASSE CALCULE LE VECTEUR NORMALE (PAS NORME) C SI IDE=IDIMC => UN REEL QUI DONNE LA SURFACE C SI IDE UN VECTEUR DONT LA NORME EST LA SURFACE C C GORIEN DOIT RENVOYER UN VECTEUR OU UN SCALAIRE C ***************************************************************** C SUBROUTINE GTAILL(IPOINT,NBPOIN,IDE,COORD,IDIMC,TAILLE,IERR) C ***************************************************************** C OBJET GTAILL : CALCULE LA TAILLE D'UN ELEMENT C EN ENTREE : C IPOINT : NUMERO DES NOEUDS DE L'ELEMENT C NBPOIN : NOMBRE DE NOEUDS DE L'ELEMENT C IDE : DIMENSION DE L'ELEMENT C COORD : COORDONNEES DES NOEUDS C IDIMC : DIMENSION DE L'ESPACE C EN SORTIE : C TAILLE : LONGUEUR D'UN SEGMENT EN 1D,2D ET 3D C SURFACE D'UN TRIANGLE EN 2D ET 3D C VOLUME D'UN TETRAEDRE (3D) C IERR : 0 SI OK, -1 SI LES DONNEES SONT ERRONEES C ***************************************************************** INTEGER IPOINT(*),NBPOIN,IDE, IDIMC REAL COORD(*) REAL TAILLE INTEGER IERR C INTEGER J REAL X C EXTERNAL TRSURF,Q4SURF,TTVO REAL TRSURF,Q4SURF,TTVO C IERR = 0 TAILLE = 0.0 GOTO (100,200,300) IDE C ============================== C ---- CAS D'UN SOMMET --- C ============================== GOTO 9999 C ============================== C ---- CAS D'UN SEGMENT --- C ============================== 100 CONTINUE DO 110 J=1,IDIMC X = COORD(((IPOINT(2)-1)*IDIMC)+J) > - COORD(((IPOINT(1)-1)*IDIMC)+J) TAILLE = TAILLE + X*X 110 CONTINUE TAILLE = SQRT( TAILLE ) GOTO 9999 C C ============================== C ---- CAS D'UN ELEMENT SURFACIQUE --- C ============================== C 200 CONTINUE IF( IDIMC.EQ.2 )THEN C ---- POLYGONE DANS LE PLAN ---- CALL G2SFPL(IPOINT, NBPOIN, COORD, TAILLE) ELSE C ---- TRIANGLE DANS L'ESPACE ---- IF( NBPOIN.EQ. 3) THEN TAILLE= TRSURF(COORD(((IPOINT(1)-1)*IDIMC)+1), > COORD(((IPOINT(2)-1)*IDIMC)+1), > COORD(((IPOINT(3)-1)*IDIMC)+1), > IDIMC) C ---- QUADRANGLE DANS L'ESPACE ---- ELSE IF( NBPOIN.EQ. 4) THEN TAILLE = Q4SURF(COORD(((IPOINT(1)-1)*IDIMC)+1), > COORD(((IPOINT(2)-1)*IDIMC)+1), > COORD(((IPOINT(3)-1)*IDIMC)+1), > COORD(((IPOINT(4)-1)*IDIMC)+1), > IDIMC) ELSE IERR = -1 CALL DSERRE(1,IERR,'GTAILL','UN POLYGONE DANS L ESPACE') GOTO 9999 ENDIF ENDIF ENDIF GOTO 9999 C ============================== C ---- CAS D'UN ELEMENT VOLUMIQUE --- C ============================== C 300 CONTINUE IF( NBPOIN.EQ.4 )THEN TAILLE = TTVO(COORD(((IPOINT(1)-1)*IDIMC)+1), > COORD(((IPOINT(2)-1)*IDIMC)+1), > COORD(((IPOINT(3)-1)*IDIMC)+1), > COORD(((IPOINT(4)-1)*IDIMC)+1)) C bug 12.11.2007 : C > IDIMC) ELSE IERR = -3 CALL DSERRE(1,IERR,'GTAILL','VOLUME DE L HEXA, DU PRISME? ') GOTO 9999 ENDIF GOTO 9999 C 9999 END C C FUNCTION GORIEN(IPOINT, NBPOIN, IDE, COORD, IDIMC, ZERO ) C ***************************************************************** C OBJET GORIEN : RENVOI L'ORIENTATION DE L'ELEMENT +1 SI POSITIF C -1 SI NEGATIF, 0 SI NUL C IPOINT : NUMERO DES NOEUDS DE L'ELEMENT C NBPOIN : NOMBRE DE NOEUDS DE L'ELEMENT C IDE : DIMENSION DE L'ELEMENT C COORD : COORDONNEES DES NOEUDS C IDIMC : DIMENSION DE L'ESPACE C ZERO : SURFACE CONSIDEREE COMME NULLE C CONDITIONS D'APPLICATIONS : N'A PAS DE SENS SI LA DIMENSION DE C L'ELEMENT EST INFERIEURE A LA DIMENSION DE L'ESPACE C POUR ORIENTER UN QUADRANGLE IL SUFFIT DE DONNER LE C PREMIER TRIANGLE. C POSITIF POUR UN TETRA AUX FACES NORMALES VERS L'INTERIEUR (TTVO) C ***************************************************************** INTEGER GORIEN INTEGER IPOINT(*),NBPOIN,IDE, IDIMC REAL COORD(*), ZERO INTEGER IERR C REAL TAILLE C TAILLE = 0.0 GORIEN= 0 CALL GTAILL(IPOINT, NBPOIN, IDE, COORD, IDIMC, TAILLE, IERR ) IF(IERR .NE. 0)THEN CALL DSERRE(1,IERR,'GORIEN','APPEL GTAILL ') GOTO 9999 ENDIF IF( TAILLE .GT. ZERO )GORIEN= 1 IF( TAILLE .LT. ZERO )GORIEN= -1 9999 END C C SUBROUTINE GBARYC(IT, N, C, IDIMC, BARYC, IERR) C ***************************************************************** C OBJET : CALCULE LE BARYCENTRE D'UN ENSEMBLE DE POINTS C EN ENTREE : C IT : NUMERO DES NOEUDS DE L'ELEMENT C N : NOMBRE DE NOEUDS DE L'ELEMENT C C : COORDONNEES DES NOEUDS C IDIMC : DIMENSION DE L'ESPACE C EN SORTIE : C IERR : 0 SI OK, -1 SI LES DONNEES SONT ERRONEES C BARYC : LE BARYCENTRE C ***************************************************************** INTEGER IT(*),N,IDIMC,IERR REAL C(*),BARYC(*) C INTEGER I,J C IERR = -1 DO 10 J=1,IDIMC BARYC(J) = 0.0 10 CONTINUE IF( N.LE. 0 ) GOTO 999 DO 30 I=1,N DO 20 J=1,IDIMC BARYC(J) = C((IT(I)-1)*IDIMC+J) + BARYC(J) 20 CONTINUE 30 CONTINUE DO 40 J=1,IDIMC BARYC(J) = BARYC(J) / N 40 CONTINUE IERR = 0 999 END C ********************************************************************** C MODULE : ST (STRUCTURE DES DONNEES) C FICHIER : ST_MATERIAU.F C OBJET : ASSOCIE LES MATERIAUX AU DIFFERENTES COMPOSANTES CONNEXES C A PARTIR DES FRONTIERES INTER-MATERIAUX C C FONCT. : C RGN1CC : ASSOCIE UNE VALEUR A LA COMPOSANTE CONNEXE C RGCOMP: RENUMEROTE LES ELEMENTS EN FONCTION DES MATERIAUX POUR C LES COMPACTER EN INTERVALS C RGRGFR : EXTRAIT LES MATERIAUX A PARTIR DE LA FRONTIERE C RGRGNO : EXTRAIT LES MATERIAUX A PARTIR DES NOEUDS DE LA FRONTIERE C RGFRRG : EXTRAIT LES FRONTIERES A PARTIR DES MATERIAUX C RGNORG : EXTRAIT LES NOEUDS DES FRONTIERES A PARTIR DES MATERIAUX C C C AUTEUR : O. STAB C DATE : 08.95 C MODIFICATIONS : C AUTEUR, DATE, OBJET : C C C ********************************************************************** C SUBROUTINE RGN1CC(IT,IVAL,IDE,ITRTRI,NBCMAX,NBE, > ITVL,ITBVAL,NBEVAL,IERR) C ********************************************************************** C OBJET RGN1CC : ASSOCIE UNE VALEUR A LA COMPOSANTE CONNEXE C EN ENTREE : C IT : UN ELEMENT DE LA COMPOSANTE CONNEXE C IVAL : UNE VALEUR NON-NULLE A ASSOCIER A LA CC C IDE : DIMENSION DES ELEMENTS DU MAILLAGE C ITRTRI : TABLEAU DES ELEMENTS VOISINS C NBNMAX : NOMBRE MAXI. D'ELEMENTS VOISINS C NBE : NOMBRE D'ELEMENTS C C ITVL : TABLEAU DE TRAVAIL = NBE + PILE (APPEL TMA1CC) C C EN SORTIE : C ITBVAL : SI ITC CONNEXE A IT ALORS ITBVAL(ITC) = IVAL C NBEVAL : NOMBRE D'ELEMENTS MARQUES A IVAL C IERR : 0 SI OK C -1 SI IVAL = 0 C ********************************************************************** INTEGER IT,IVAL,IDE,ITRTRI(*),NBCMAX,NBE INTEGER ITVL(*),ITBVAL(*),NBEVAL,IERR C INTEGER ITRAV,NBTRAV,I C IERR = -1 NBEVAL = 0 IF( IVAL.EQ.0 )GOTO 999 IERR = 0 ITRAV = NBE + 1 NBTRAV = NBE CALL TMA1CC(IDE,ITRTRI,NBCMAX,1,NBE, > IT,ITVL(ITRAV),ITBVAL,NBTRAV, > ITVL,NBEVAL,IERR) IF( IERR.NE. 0 )GOTO 999 DO 10 I=1,NBEVAL ITBVAL(ITVL(I)) = IVAL 10 CONTINUE 999 END C C C SUBROUTINE RGRGFR(IFR,NBIFR,IMATFR, > IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX, > NOETRI,NBE,ITVL, > IMAT,IRGREF,IMATCC,NBRGCC,NCCMAX,IERR) C ********************************************************************** C OBJET RGRGFR : AFFECTE LES MATERIAUX A PARTIR DE LA FRONTIERE C C EN ENTREE : C IFR : FRONTIERE C IFR((I-1)*2+1) IEME ELEMENT FRONTIERE C IFR((I-1)*2+2) COTE DU IEME ELEMENT FRONTIERE C NBIFR : NOMBRE D'ELEMENTS FRONTIERE C C IMATFR : IMATFR((I-1)*2+1) EST LE MATERIAU A GAUCHE DE IFR((I-1)*2+1) C SUR LE COTE IFR((I-1)*2+2) C IMATFR((I-1)*2+2) EST LE MATERIAU A DROITE DE IFR((I-1)*2+1) C SUR LE COTE IFR((I-1)*2+2) C C IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,NBE : LE MAILLAGE C C ITVL: TABLEAU DE TRAVAIL DE TAILLE = NBE + PILE (APPEL TMA1CC) C C IMAT : TABLEAU DE SORTIE TAILLE = NBE C IRGREF : " " TAILLE = NCCMAX C IMATCC : " " TAILLE = NCCMAX C NCCMAX : TAILLE DE IRGREF ET IMATCC C SI = 0 ALORS ON NE REMPLI PAS IRGREF ET IMATCC C C EN SORTIE : C IMAT : IMAT(I) EST LE MATERIAU DE L'ELEMENT I C IRGREF : TABLEAU DES MATERIAUX DE CHAQUE COMPOSANTE CONNEXE C IMATCC : UN ELEMENT DE CHAQUE COMPOSANTE CONNEXE C NBRGCC : NOMBRE DE COMPOSANTE CONNEXE MONO-MATERIAU C C IERR : CODE D'ERREUR C -1 UN ELEMENT FRONTIERE DE IFR N'EXISTE PAS C TOUS LES ELEMENTS N'ONT PAS UN MATERIAU ! C -2 ITVL, IRGREF OU IMATCC TROP PETIT C ********************************************************************** INTEGER IFR(*),NBIFR,IMATFR(*) INTEGER IDE,ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX INTEGER NOETRI(*),NBE,ITVL(*) INTEGER IMAT(*),IRGREF(*),IMATCC(*),NBRGCC,NCCMAX,IERR C INTEGER I,J,MAT INTEGER NBVUE,IT1,IT2,I1,NBEMAT C IF( NBIFR.EQ. 0)THEN C ========================================================== C --- 1. MONO-MATERIAU : TOUS LES TRIANGLES SONT DE MATERIAU 1 --- C ========================================================== MAT = IMATFR(1) IF( MAT.LE. 0 )MAT = IMATFR(2) DO 10 I=1,NBE 10 IMAT(I) = MAT IF( NCCMAX.GT.0 )THEN IRGREF(1) = MAT IMATCC(1) = 1 ENDIF C ELSE C ======================================= C --- 2. PLUSIEURS MATERIAUX ---- C ======================================= C C ===================== C --- 2.1. INITIALISATION ---- C ===================== DO 15 I=1,NBIFR IT1 = IFR((I-1)*2+1) I1 = ABS(IFR((I-1)*2+2)) IT2 = ITRTRI((IT1-1)*NBCMAX+I1) IF( IT2 .LE. 0 )GOTO 15 ITRTRI((IT1-1)*NBCMAX+I1) = - IT2 DO 11 J=1,NBCMAX IF( ITRTRI((IT2-1)*NBCMAX+J).EQ.IT1 )THEN ITRTRI((IT2-1)*NBCMAX+J) = -IT1 GOTO 15 ENDIF 11 CONTINUE 15 CONTINUE DO 20 I=1,NBE IMAT(I) = 0 20 CONTINUE C ==================================================== C --- 2.2. RECHERCHE DES MATERIAUX C ==================================================== C NBRGCC = 0 NBVUE = 0 DO 30 I=1,NBIFR IT1 = IFR((I-1)*2+1) I1 = ABS(IFR((I-1)*2+2)) IT2 = ABS(ITRTRI((IT1-1)*NBCMAX+I1)) C ------- MATERIAU A GAUCHE ---------- C =================== NBEMAT = 0 C --- VERIFICATION --- IF((IT1.NE.0).AND.(IMAT(IT1).NE.0).AND. > (IMATFR((I-1)*2+1).GT.0))THEN IF( IMAT(IT1).NE.IMATFR((I-1)*2+1) )THEN IERR = -1 CALL DSERRE(1,IERR,'RGRGFR', > ' 1 ELEMENT A 2 MATERIAUX') ENDIF ENDIF C --- FIN DE VERIFICATION --- IF((IT1.NE.0).AND.(IMAT(IT1).EQ.0).AND. > (IMATFR((I-1)*2+1).GT.0))THEN NBRGCC = NBRGCC + 1 CALL RGN1CC(IT1,IMATFR((I-1)*2+1),IDE,ITRTRI, > NBCMAX,NBE,ITVL,IMAT,NBEMAT,IERR) IF( NBRGCC.LE.NCCMAX )THEN IRGREF(NBRGCC) = IMATFR((I-1)*2+1) IMATCC(NBRGCC) = IT1 ENDIF ENDIF C ------- MATERIAU A DROITE ----------- C =================== NBVUE = NBEMAT + NBVUE NBEMAT = 0 C --- VERIFICATION --- IF((IT2.NE.0).AND.(IMAT(IT2).NE.0).AND. > (IMATFR((I-1)*2+2).GT.0))THEN IF( IMAT(IT2).NE.IMATFR((I-1)*2+2) )THEN IERR = -1 CALL DSERRE(1,IERR,'RGRGFR', > ' 1 ELEMENT A 2 MATERIAUX') ENDIF ENDIF C --- FIN DE VERIFICATION --- IF((IT2.NE.0).AND.(IMAT(IT2).EQ.0).AND. > (IMATFR((I-1)*2+2).GT.0))THEN NBRGCC = NBRGCC + 1 CALL RGN1CC(IT2,IMATFR((I-1)*2+2),IDE,ITRTRI, > NBCMAX,NBE,ITVL,IMAT,NBEMAT,IERR) IF( NBRGCC.LE.NCCMAX )THEN IRGREF(NBRGCC) = IMATFR((I-1)*2+2) IMATCC(NBRGCC) = IT2 ENDIF ENDIF NBVUE = NBEMAT + NBVUE C --- FIN : ON A ATTRIBUE UN MAT. A TOUS LES ELEMENTS ---- IF( NBVUE.EQ.NBE )GOTO 888 C --- BOUCLE : ON A PAS VU TOUS LES ELEMENTS --- 30 CONTINUE C --- ON A PAS VU TOUS LES ELEMENTS ----- IERR = -1 CALL DSERRE(1,IERR,'RGRGFR', ' ELEMENTS NON VUS ! ') GOTO 999 C 888 IF((NCCMAX.NE.0).AND. > (NCCMAX.LT.NBRGCC))THEN IERR = -2 CALL DSERRE(1,IERR,'RGRGFR', ' IRGREF ET IMATCC') GOTO 999 ENDIF C C --- UNE ARETE DE LA FRONTIERE N'EXISTE PAS --- IF( IERR.NE. 0 )GOTO 999 ENDIF C 999 END C C SUBROUTINE RGRGNO(IFR,NBNIFR,NBIFR,IMATFR, > IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX, > NOETRI,NBE,ITVL,NITMAX, > IMAT,IRGREF,IMATCC,NBRGCC,NCCMAX,IERR) C ********************************************************************** C OBJET RGRGNO : EXTRAIT LES REGIONS A PARTIR DES NOEUDS DE LA FRONTIERE C VOIR RGRGFR C C EN ENTREE : IDEM RGRGFR C NBNIFR : NOMBRE DE NOEUDS DES ELEMENTS DE LA FRONTIERE C C ITVL : TAILLE > 2*NBIFR + NBE + PILE (APPEL TMA1CC) C C NCCMAX : TAILLE DE IRGREF ET IMATCC C SI = 0 ALORS ON NE REMPLI PAS IRGREF ET IMATCC C EN SORTIE : C IMAT : IMAT(I) EST LE MATERIAU DE L'ELEMENT I C IRGREF : IRGREF(I) = MATERIAUX DE LA COMPOSANTE CONNEXE I C IMATCC : IMATCC(I) = UN ELEMENT DE LA COMPOSANTE CONNEXE I C NBRGCC : NOMBRE DE COMPOSANTE CONNEXE MONO-MATERIAU C C IERR : CODE D'ERREUR C -1 UN ELEMENT FRONTIERE DE IFR N'EXISTE PAS C TOUS LES ELEMENTS N'ONT PAS UN MATERIAU ! C -2 ITVL, IRGREF OU IMATCC TROP PETIT C C REMARQUE : IL FAUDRAIT TESTER LE CAS D'UN MATERIAU EN PLUSIEURS CC ! C ********************************************************************** INTEGER IFR(*),NBIFR,NBNIFR,IMATFR(*) INTEGER IDE,ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX INTEGER NOETRI(*),NBE,ITVL(*),NITMAX INTEGER IMAT(*),IRGREF(*),IMATCC(*),NBRGCC,NCCMAX,IERR C INTEGER I,MAT,ITRAV,NITMX2 INTEGER IT1,IT2,I1,I2 C IF( NBIFR.EQ. 0)THEN C ========================================================== C --- 1. MONO-MATERIAU : TOUS LES TRIANGLES SONT DE MATERIAU 1 --- C ========================================================== NBRGCC = 1 MAT = IMATFR(1) IF( MAT.LE. 0 )MAT = IMATFR(2) DO 10 I=1,NBE 10 IMAT(I) = MAT IF( NCCMAX.GT.0 )THEN IRGREF(1) = MAT IMATCC(1) = 1 ENDIF IERR = 0 GOTO 9999 ENDIF C IERR = 0 NBRGCC = 0 ITRAV = 2*NBIFR+1 NITMX2 = NITMAX - ITRAV DO 30 I=1,NBIFR CALL SFRIDE(IFR((I-1)*NBNIFR+1),NBNIFR,IDE, > ITRNOE,NBNMAX,ITRTRI,NBCMAX, > NOETRI,NBE,ITVL(ITRAV),NITMX2, > IT1,IT2,I1,I2,IERR ) IF(IERR.NE.0)THEN CALL DSERRE(1,IERR,'RGRGNO','APPEL SFRIDE') GOTO 9999 ENDIF IF( IT1.NE.0 )THEN ITVL((I-1)*2+1) = IT1 ITVL((I-1)*2+2) = I1 ELSE C IF( IMATFR((I-1)*2+1).NE. 0 )GOTO 999 IF( IT2.EQ. 0 )THEN IERR = -1 CALL DSERRE(1,IERR,'RGRGNO','STRUCTURE INCORRECTE') GOTO 9999 ENDIF ITVL((I-1)*2+1) = IT2 ITVL((I-1)*2+2) = I2 ENDIF 30 CONTINUE C CALL RGRGFR(ITVL,NBIFR,IMATFR, > IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX, > NOETRI,NBE,ITVL(ITRAV), > IMAT,IRGREF,IMATCC,NBRGCC,NCCMAX,IERR) IF(IERR.NE.0)THEN CALL DSERRE(1,IERR,'RGRGNO','APPEL RGRGFR') GOTO 9999 ENDIF C 9999 END C SUBROUTINE RGCOMP(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX, > NOETRI,NOEMAX,NBE,ITVL, > IMAT,IRGREF,NRGREF, > IREFMA,ITRIRG,NREFRG,NRRGMX,IERR) C ********************************************************************** C OBJET RGCOMP : RENUMEROTE LES ELEMENTS EN FONCTION DU NUMERO DE REGION C (POUR LES COMPACTER EN INTERVALS) C C EN ENTREE : C IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,NBE : LE MAILLAGE C C ITVL : TABLEAU DE TRAVAIL DE MAX(NRGREF,2*NBE) C SI NRGREF = 1 SEUL ITVL(1) EST UTILISE C C IMAT : IMAT(I) EST LE NUMERO DU MATERIAU DE L'ELEMENT I C IRGREF(IMAT(I)) EST LA REFERENCE DU MATERIAU DE L'ELEMENT I C IRGREF : TABLEAU DES REFERENCES DES MATERIAUX C NRGREF : NOMBRE DE REFERENCES DANS IRGREF C DANS LE CAS OU L'ON NE CONNAIT PAS IRGREF ET NRGREF C ON PEUT DONNER IMAT,NBE C C IREFMA : TABLEAU DE SORTIE TAILLE = NRRGMX (ON PEUT UTILISER IRGREF) C ITRIRG : " " TAILLE = NRRGMX C NRRGMX : TAILLE DE IREFMA ET ITRIRG C SI = 0 ALORS ON NE REMPLI PAS IREFMA ET ITRIRG C C EN SORTIE : C IREFMA : IREFMA(I) = REFERENCE DU IEME MATERIAU C (ON PEUT UTILISER IRGREF) C ITRIRG : ITRIRG(I-1)+1, ITRIRG(I) = INTERVAL CONTENANT C LE ELEMENTS DE MATERIAU IREFMA(I) C NBRGCC : NOMBRE DE MATERIAUX (= NOMBRE D'INTERVALS) C C IERR : CODE D'ERREUR C ********************************************************************** INTEGER IDE,ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX INTEGER NOETRI(*),NOEMAX,NBE,ITVL(*) INTEGER IMAT(*),IRGREF(*),NRGREF INTEGER IREFMA(*),ITRIRG(*),NREFRG,NRRGMX,IERR C INTEGER ITRAV,INUM,I C IF(NBE.EQ.0)GOTO 999 C --- 1.1 COMPRESSION DES MATERIAUX (CAS PLUSIEURS CC) --- C ================================================== ITRAV = 1 C --- TAILLE ITVL > NRGREF --- CALL TBVTAB(IRGREF,NRGREF,ITVL(ITRAV), > IREFMA,NREFRG,NRRGMX,IERR) IF( IERR .NE. 0 )THEN CALL DSERRE(1,IERR,'RGCOMP','APPEL TBVTAB') GOTO 999 ENDIF IF( NREFRG.EQ.1 )THEN ITRIRG(1) = NBE GOTO 999 ENDIF C C --- 1.2 RENUMEROTATION DES ELEMENTS --------------------- C ================================= INUM = 1 C --- TAILLE ITVL > NBE --- CALL TBNUIT(IMAT,NBE,IREFMA,NREFRG, > ITVL(INUM), > ITRIRG,IERR) IF( IERR .NE. 0 )THEN CALL DSERRE(1,IERR,'RGCOMP','APPEL TBNUIT') GOTO 999 ENDIF C ITRAV = NBE + INUM CALL NURENU(IDE,ITRNOE,NBNMAX, > ITRTRI,NBCMAX,NOETRI, > NOEMAX,NBE,ITVL(INUM),ITVL(ITRAV),IERR) IF( IERR .NE. 0 )THEN CALL DSERRE(1,IERR,'RGCOMP','APPEL NURENU') GOTO 999 ENDIF C DO 10 I=2,NREFRG ITRIRG(I) = ITRIRG(I-1) + ITRIRG(I) 10 CONTINUE C 999 END C SUBROUTINE RGFRRG(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX, > NBE,IMAT,NBMAT, > IFR,NBIFR,NIFMAX,IMATFR,NRGMAX,IERR) C ********************************************************************** C OBJET RGFRRG: EXTRAIT LES FRONTIERES A PARTIR DES MATERIAUX C C EN ENTREE : C IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NBE : LE MAILLAGE C IMAT : IMAT(I) EST LE MATERIAU DE L'ELEMENT I C NBMAT : NOMBRE DE MATERIAU C C NIFMAX : NOMBRE MAXIMUM D'ELEMENTS FRONTIERE C NRGMAX : SI = 0 ON NE REMPLI PAS IMATFR C SINON NOMBRE MAXIMUM DE REFERENCE DES ELEMENTS C FRONTIERE C IFR : EST UN TABLEAU DE SORTIE DE 2*NIFMAX C IMATFR : EST UN TABLEAU DE SORTIE INUTILISE SI NRGMAX = 0 C DE 2*NRGMAX SINON. NOTONS QUE LA MEME TAILLE EST C SOUHAITE POUR IFR ET IMATFR C C EN SORTIE : C IFR : FRONTIERES C IFR((I-1)*2+1) ELEMENT APPARTENANT A LA FRONTIERE C IFR((I-1)*2+2) COTE DE L'ELEMENT SUR LA FRONTIERE C " " " POSITIF SI C'EST UNE FRONTIERE REELLE C " " " NEGATIF SI C'EST UNE FRONTIERE INTERIEURE C NBIFR : NOMBRE D'ELEMENTS FRONTIERE C (LES ELEMENTS DES FRONTIERES INTERIEURES SONT COMPTES 2 FOIS) C C IMATFR : IMATFR((I-1)*2+1) EST LE MATERIAU DE IFR((I-1)*2+1) C IMATFR((I-1)*2+2) EST LE MATERIAU DU VOISIN DE C IFR((I-1)*2+1) SUR LE COTE IFR((I-1)*2+2) C C IERR : CODE D'ERREUR C 0 SI OK C -2 SI IFR OU IMATFR SONT TROP PETITS C ********************************************************************** INTEGER IDE,ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX,NBE INTEGER IMAT(*),NBMAT,NIFMAX,NRGMAX INTEGER IFR(*),IMATFR(*),NBIFR,IERR C INTEGER IGMAT,JDMAT,I,J,JVOIS,NBC,NBRN INTEGER STRNBN,STRNBC EXTERNAL STRNBN,STRNBC C IGMAT = 1 JDMAT = 1 NBIFR = 0 DO 20 I=1,NBE NBRN = STRNBN(I,ITRNOE,NBNMAX) NBC = STRNBC(NBRN,IDE) IF( NBMAT.NE. 0 )IGMAT = IMAT(I) DO 10 J=1,NBC C JVOIS = ABS(ITRTRI((I-1)*NBNMAX+J)) C REMPLACE PAR : O.STAB 29.07.99 JVOIS = ABS(ITRTRI((I-1)*NBCMAX+J)) C ---- FRONTIERE EXTERNE (PAS DE VOISIN) ---- IF( JVOIS .EQ. 0 )THEN NBIFR = NBIFR+1 IF( NIFMAX.GE. NBIFR )THEN IFR((NBIFR-1)*2+1) = I IFR((NBIFR-1)*2+2) = J ELSE IERR = -2 ENDIF IF( NRGMAX.GE. NBIFR )THEN IMATFR((NBIFR-1)*2+1) = IGMAT IMATFR((NBIFR-1)*2+2) = 0 ELSE IF( NRGMAX.NE. 0 )IERR = -2 ENDIF GOTO 10 ENDIF C IF( NBMAT.NE. 0 )JDMAT = IMAT(JVOIS) IF( IGMAT.EQ.JDMAT )GOTO 10 C ---- FRONTIERE INTERNE (VOISIN DE MAT DIFF) ---- NBIFR = NBIFR+1 IF( NIFMAX.GE. NBIFR )THEN IFR((NBIFR-1)*2+1) = I IFR((NBIFR-1)*2+2) = -J ELSE IERR = -2 ENDIF IF( NRGMAX.GE. NBIFR )THEN IMATFR((NBIFR-1)*2+1) = IGMAT IMATFR((NBIFR-1)*2+2) = JDMAT ELSE IF( NRGMAX.NE. 0 )IERR = -2 ENDIF 10 CONTINUE 20 CONTINUE C 999 END C C SUBROUTINE RGNORG(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX, > NBE,IMAT,NBMAT, > IFR,NBIFR,NIFMAX,NBNIFR,IMATFR,NRGMAX,IERR) C ********************************************************************** C OBJET RGNORG : EXTRAIT LES NOEUDS DES FRONTIERES DES REGIONS C VOIR RGFRRG C C EN ENTREE : IDEM RGFRRG C NBNIFR : NOMBRE MAX. DE NOEUD DES ELEMENTS FRONTIERE C EN SORTIE : C IFR : FRONTIERE C IFR((I-1)*NBNIFR+1) PREMIER NOEUD DE L'ELEMENT FRONTIERE I C IFR((I-1)*NBNIFR+2) DEUXIEME " " " " " " I C NBIFR : NOMBRE D'ELEMENTS FRONTIERE C C ********************************************************************** INTEGER IDE,ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX,NBE INTEGER IMAT(*),NBMAT,NIFMAX,NRGMAX INTEGER IFR(*),IMATFR(*),NBIFR,NBNIFR,IERR C INTEGER IIFR,I C IERR = 0 C --- ON DECALE A PRIORI LE DEBUT POUR NE PAS AVOIR A REDECALER C A LA FIN ET ECONOMISER DE LA PLACE --- C IIFR = (NIFMAX * (NBNIFR - 2)) + 1 CALL RGFRRG(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX, > NBE,IMAT,NBMAT,IFR(IIFR),NBIFR,NIFMAX, > IMATFR,NRGMAX,IERR) IF( IERR.NE. 0 )GOTO 999 IF( ((NBNIFR - 2) * NBIFR).GT.IIFR )THEN IERR = -2 GOTO 999 ENDIF C DO 10 I=1,NBIFR CALL TNOFRT(IDE,ITRNOE,NBNMAX,IFR((I-1)*2+IIFR), > IFR((I-1)*2+IIFR+1),IFR((I-1)*NBNIFR+1)) 10 CONTINUE C 999 END C C ***************************************************************** C MODULE : ST (STRUCTURE DES DONNEES) C FICHIER : ST_TABLEAU.F C OBJET : MANIPULATION DE TABLEAUX D'ENTIERS C FONCT. : C FONCTIONS DE TRI : C ----------------- C KNUTP : DONNE L'ORDRE CROISSANT POUR UN TABLEAU D'ENTIERS C TRI PAR INCREMENT DECROISSANT (SHELL SORTING - KNUTH 1973) C KNUTA : TRI UN TABLEAU D'ENTIERS DANS L'ORDRE CROISSANT C IORDRE : IMPOSE UN ORDRE DONNE A UN TABLEAU D'ENTIERS C INVORD : INVERSE L'ORDRE D'UN TABLEAU D'ENTIERS C C INTERVALLES : C ------------- C TBV2IT : CONVERTIT UN TABLEAU D'ENTIER EN UN TABLEAU C D'INTERVALLES C TBIT2V : CONVERTIT UN TABLEAU D'INTERVALLES EN TABLEAU C D'ENTIERS C TBNUIT : DONNE UNE NUMEROTATION POUR OBTENIR DES INTERVALS C TBVTAB : RENVOI LES VALEURS DISTINCTES D'UN TABLEAU, C TRIEES DANS L'ORDRE CROISSANT C C C AUTEUR : O. STAB C DATE : 08.95 C MODIFICATIONS : C AUTEUR, DATE, OBJET : stab,7.5.2002, bug dans TBV2IT C C C ***************************************************************** C C SUBROUTINE KNUTP(N,L,NARG) C *************************************************************** C OBJET : DONNE L'ORDRE CROISSANT POUR UN TABLEAU D'ENTIERS C TRI PAR INCREMENT DECROISSANT (SHELL SORTING - KNUTH 1973) C C ON TRIE LES N TERMES NARG(I) POUR I=1,N C C TRI PAR INCREMENT DECROISSANT (SHELL SORTING) C COMPLEXITE EN N PUISSANCE 3/2 ET MEME STATISTIQUEMENT EN N**1.2 C C POUR EN SAVOIR PLUS : KNUTH, "THE ART OF COMPUTER PROGRAMMING", C VOL 3 : SORTING AND SEARCHING, C ADDISON-WESLEY, 1973. C C KNUTP : P COMME PASSIF, C.A.D. QUE LES ARGUMENTS NARG(I) POUR C I=1 A N NE SONT PAS "PERMUTES" (TABLEAU NARG NON MODIFIE). C MAIS CE MODULE DETERMINE LE TABLEAU L(I) POUR I=1 A N C DE SORTE QUE LA SUITE NARG(L(I)) SOIT ORDONNEE. C VOIR AUSSI KNUTA. C C REMARQUE : NARG PEUT ETRE DE TOUT TYPE ET TOUTE LOI D'ORDRE C PEUT ETRE INTRODUITE. IL SUFFIT D'INTERVENIR C AUX ENDROITS INDIQUES AINSI : '***** ICI : ...'. C C *************************************************************** INTEGER N,L(*),NARG(*) INTEGER NARGJ INTEGER I,J,II,JJ,K,INCR C C ON N'A RIEN A TRIER C IF(N.LE.0) GOTO 9999 DO 10 I=1,N L(I)=I 10 CONTINUE IF(N.LE.1) GOTO 9999 C C POUR J=INCR+1,N, LA SOUS-SUITE NARG(L(J+H*INCR)), H=...,-3,-2,-1,0 C SERA ORDONNEE (TRI HABITUEL PAR INSERTION SEQUENTIELLE). C C DES QUE INCR=1 ON A ATTEINT L'OBJECTIF FINAL. C C INCR SUBIT UNE DECROISSANCE PROGRESSIVE DE SORTE QU'AU C DEBUT IL EST GRAND (LA SOUS-SUITE A TRIER A UN CARDINAL FAIBLE) C ENSUITE QUAND INCR DIMINUE LA PROFONDEUR DES PERMUTATIONS C NECESSAIRES RESTE LIMITEE GRACE AU TRI DE LA SOUS-SUITE C CORRESPONDANT A LA VALEUR PRECEDENTE DE L'INCREMENT (LE PAS). C INCR=N C C DECROISSANCE DE L'INCREMENT PAR DIVISION PAR 2 C 20 INCR=INCR/2 C C POUR TOUT J VARIANT DE INCR+1 A N, C LA SOUS-SUITE NARG(L(J+H*INCR)) AVEC H=...,-3,-2,-1,0 C SERA ORDONNEE. C DO 50 J=INCR+1,N C C ON PROCEDE PAR RECURENCE : LE FAIT QUE LES ELEMENTS C NARG(L(J+H*INCR)) DEPUIS LE DEBUT JUSQU'A J+H*INCR=K-INCR C SOIENT DEJA ORDONNES EST UTILISE POUR ALLER JUSTE PLACER C CONVENALEMENT L'ELEMENT L(K) : INSERTION SEQUENTIELLE. C JJ=L(J) NARGJ=NARG(JJ) K=J DO 30 I=J-INCR,1,-INCR II=L(I) C C ***** ICI : LOI D'ORDRE C COMPARER NARG(II) ET NARGJ=NARG(JJ) C SI NARG(II) EST AVANT OU EGAL A NARGJ ALLER EN 40 C IF(NARG(II).LE.NARGJ) GOTO 40 C C DECALLAGE VERS LA DROITE DU I EME TERME C L(K)=II K=I 30 CONTINUE C C ON VIENT DE TROUVER LA PLACE CONVENABLE POUR NARG(L(J)) C 40 L(K)=JJ C C FIN DU TRI DE LA SOUS-SUITE ASSOCIEE A J C 50 CONTINUE C C PEUT-ON ENCORE DIMINUER L'INCREMENT (LE PAS) ? C IF(INCR.GT.1) GOTO 20 C C INCR=1, LE TRI FINAL EST ACHEVE. MERCI DE VOTRE VISITE. C 9999 END C C C SUBROUTINE KNUTA(N,NARG) C *************************************************************** C OBJET : TRI UN TABLEAU D'ENTIERS DANS L'ORDRE CROISSANT C TRI PAR INCREMENT DECROISSANT (SHELL SORTING - KNUTH 1973) C C ON TRIE LES N TERMES NARG(I) POUR I=1,N C C TRI PAR INCREMENT DECROISSANT (SHELL SORTING) C COMPLEXITE EN N PUISSANCE 3/2 ET MEME STATISTIQUEMENT EN N**1.2 C C POUR EN SAVOIR PLUS : KNUTH, "THE ART OF COMPUTER PROGRAMMING", C VOL 3 : SORTING AND SEARCHING, C ADDISON-WESLEY, 1973. C C KNUTA : A COMME ACTIF, C.A.D. QUE LES ARGUMENTS NARG(I) POUR C I=1 A N SONT PHYSIQUEMENT "PERMUTES" (TABLEAU NARG MODIFIE). C VOIR AUSSI KNUTP. C C C REMARQUE : NARG PEUT ETRE DE TOUT TYPE ET TOUTE LOI D'ORDRE C PEUT ETRE INTRODUITE. IL SUFFIT D'INTERVENIR C AUX ENDROITS INDIQUES AINSI : '***** ICI : ...'. C C *************************************************************** INTEGER N,NARG(*) INTEGER NARGJ INTEGER I,J,K,INCR C C ON N'A RIEN A TRIER C IF(N.LE.1) GOTO 9999 C C POUR J=INCR+1,N, LA SOUS-SUITE NARG(J+H*INCR), H=...,-3,-2,-1,0 C SERA ORDONNEE (TRI HABITUEL PAR INSERTION SEQUENTIELLE). C C DES QUE INCR=1 ON A ATTEINT L'OBJECTIF FINAL. C C INCR SUBIT UNE DECROISSANCE PROGRESSIVE DE SORTE QU'AU C DEBUT IL EST GRAND (LA SOUS-SUITE A TRIER A UN CARDINAL FAIBLE) C ENSUITE QUAND INCR DIMINUE LA PROFONDEUR DES PERMUTATIONS C NECESSAIRES RESTE LIMITEE GRACE AU TRI DE LA SOUS-SUITE C CORRESPONDANT A LA VALEUR PRECEDENTE DE L'INCREMENT (LE PAS). C INCR=N C C DECROISSANCE DE L'INCREMENT PAR DIVISION PAR 2 C 10 INCR=INCR/2 C C POUR TOUT J VARIANT DE INCR+1 A N, C LA SOUS-SUITE NARG(J+H*INCR) AVEC H=...,-3,-2,-1,0 C SERA ORDONNEE. C DO 40 J=INCR+1,N C C ON PROCEDE PAR RECURENCE : LE FAIT QUE LES ELEMENTS C NARG(J+H*INCR) DEPUIS LE DEBUT JUSQU'A J+H*INCR=K-INCR C SOIENT DEJA ORDONNES EST UTILISE POUR ALLER JUSTE PLACER C CONVENALEMENT L'ELEMENT NARG(K) : INSERTION SEQUENTIELLE. C C C ***** ICI : SAUVEGARDE DE NARG(J) C NARGJ=NARG(J) K=J DO 20 I=J-INCR,1,-INCR C C ***** ICI : LOI D'ORDRE C COMPARER NARG(I) ET NARGJ=NARG(J) C SI NARG(I) EST AVANT OU EGAL A NARGJ ALLER EN 30 C IF(NARG(I).LE.NARGJ) GOTO 30 C C ***** ICI : AFFECTER LE CONTENU DE NARG(I) A NARG(K) C NARG(K)=NARG(I) K=I 20 CONTINUE C C ***** ICI : AFFECTER LE CONTENU DE NARGJ A NARG(K) C 30 NARG(K)=NARGJ C C FIN DU TRI DE LA SOUS-SUITE ASSOCIEE A J C 40 CONTINUE C C PEUT-ON ENCORE DIMINUER L'INCREMENT (LE PAS) ? C IF(INCR.GT.1) GOTO 10 C C INCR=1, LE TRI FINAL EST ACHEVE. MERCI DE VOTRE VISITE. C 9999 END C C C SUBROUTINE IORDRE(N,L,M,NARG) C *************************************************************** C OBJET : IMPOSE UN ORDRE DONNE A UN TABLEAU D'ENTIERS C C IMPOSER UN ORDRE (FOURNI DANS LE TABLEAU L) A UN TABLEAU NARG C M : TABLEAU DE TRAVAIL D'AU MOINS N ENTIERS C C ENTREE : C POUR I=1 A N, NARG(L(I)) EST LE I EME ARGUMENT DANS LA LISTE C ORDONNEE. IL OCCUPE DONC INITIALEMENT LA POSITION L(I). C C ATTENTION : L SOIT ETRE UNE PERMUTATION DES N ENTIERS DE 1 A N. C C SORTIE : C POUR I=1 A N, NARG(I) EST LE I EME ARGUMENT DANS LA LISTE C ORDONNEE. IL OCCUPE DONC LA POSITION I CORESPONDANT A SON RANG. C POSONS J=L(J), ALORS NARG(M(J)) EST MAINTENANT L'ARGUMENT QUI C INITIALEMENT ETAIT A LA POSITION J. C AUTREMENT DIT, LE TABLEAU M EST LA PERMUTATION RECIPROQUE DE L. C EN PARTICULIER, LES DEUX APPELS SUCCESSIFS SUIVANTS CONDUISENT C A LA FABRICATION DE M (A PARTIR DE L) ET A NARG INCHANGE : C CALL IORDRE(N,L,M,NARG) PUIS CALL IORDRE(N,M,L,NARG). C C *************************************************************** INTEGER N,L(*),M(*),NARG(*) INTEGER NARGI INTEGER I,LI,MI C C ON N'A RIEN A FAIRE C IF(N.LE.1) GOTO 9999 C C PERMUTATION M INVERSE DE L : C DO 10 I=1,N M(L(I))=I 10 CONTINUE C C IMPOSER A NARG L'ORDRE DEFINI PAR L. C LES TABLEAUX L ET M SONT CASSES. C DO 20 I=1,N LI=L(I) MI=M(I) NARGI=NARG(I) NARG(I)=NARG(LI) NARG(LI)=NARGI L(MI)=LI M(LI)=MI 20 CONTINUE C C RESTAURATION DES TABLEAUX L (INITIAL) ET M (SON INVERSE). C DO 30 I=1,N LI=L(I) MI=M(I) L(MI)=I M(LI)=I 30 CONTINUE 9999 END C C C SUBROUTINE INVORD(N,NARG) C *************************************************************** C OBJET : INVERSE L'ORDRE D'UN TABLEAU D'ENTIERS C C INVERSER L'ODRDRE DANS LE TABLEAU NARG C C ENTREE : C N TERMES NARG(1),NARG(2), ... , NARG(N) C C SORTIE : C LA TABLEAU NARG DEVIENT : NARG(N),NARG(N-1), ... , NARG(1) C C *************************************************************** INTEGER N,NARG(*) INTEGER NARGI INTEGER I C C ON N'A RIEN A FAIRE C IF(N.LE.1) GOTO 9999 C C PERMUTATION DE NARG(I) ET DE NARG(N+1-I) C DO 10 I=1,N NARGI=NARG(I) NARG(I)=NARG(N+1-I) NARG(N+1-I)=NARGI 10 CONTINUE 9999 END C SUBROUTINE TBV2IT(ITABRG,NBE,INVMAX,IREFRG,NBINTV, > NINVMX,IERR) C ********************************************************************** C OBJET TBV2IT : CONVERTIT UN TABLEAU D'ENTIERS EN UN TABLEAU D'INTERVALLES C LE TABLEAU N'EST PAS COMPRIME (VOIR RGCOMP) C EN ENTREE : C ITABRG : TABLEAU D'ENTIERS C NBE : TAILLE DU TABLEAU D'ENTIERS C C INVMAX ,IREMAT : TABLEAUX DE SORTIE C NINVMX : TAILLE DES TABLEAUX C C EN SORTIE : C INVMAX : INVMAX(I-1)+1,INVMAX(I) PREMIER ET DERNIER ELEMENTS DE C DE L'INTERVAL I C IREMAT : IREMAT(I) ENTIER ASSOCIEE A L'INTERVAL I C NBINTV : NOMBRE D'INTERVALS C IERR : -2 SI INVMAX ET IREMAT SONT TROP PETITS C ********************************************************************** INTEGER INVMAX(*),IREFRG(*),NBINTV,NINVMX INTEGER ITABRG(*),NBE,IERR C INTEGER I C IERR = -2 IF(NINVMX.LT.1)GOTO 999 NBINTV = 1 C --- bug 07.05.2002 : il faut initialiser INVMAX(1) au cas ou ! INVMAX(NBINTV) = 0 IREFRG(NBINTV) = ITABRG(1) DO 10 I=1,NBE IF( ITABRG(I).NE.IREFRG(NBINTV))THEN NBINTV = NBINTV + 1 IF( NBINTV.GT.NINVMX )GOTO 999 IREFRG(NBINTV) = ITABRG(I) INVMAX(NBINTV) = 1 ELSE INVMAX(NBINTV) = INVMAX(NBINTV) + 1 ENDIF 10 CONTINUE C --- ajout o.stab BUG 07.05.2002 --- DO 20 I=2,NBINTV INVMAX(I) = INVMAX(I) + INVMAX(I-1) 20 CONTINUE C IERR = 0 C 999 END C SUBROUTINE TBIT2V(INVMAX,IREFRG,NBINTV,ITABRG,NBE,IERR) C ********************************************************************** C OBJET TBIT2V : CONVERTIT UN TABLEAU D'INTERVALLES EN TABLEAU D'ENTIERS C C EN ENTREE : C INVMAX : INVMAX(I-1)+1,INVMAX(I) PREMIER ET DERNIER ELEMENTS DE C DE L'INTERVAL I C IREMAT : IREMAT(I) ENTIER ASSOCIEE A L'INTERVAL I C NBINTV : NOMBRE D'INTERVALS C C ITABRG : TABLEAU A REMPLIR C NBE : TAILLE DU TABLEAU A REMPLIR C EN SORTIE : C ITABRG : ITABRG(I) EST LA VALEUR DE L'ELEMENT I C IERR : -1 SI UNE REFERENCE EST HORS DE [1:NBE] C ********************************************************************** INTEGER INVMAX(*),IREFRG(*),NBINTV INTEGER ITABRG(*),NBE,IERR C INTEGER I,J,IDMAT,IFMAT C IERR = -1 IDMAT = 1 DO 20 I=1,NBINTV IFMAT = INVMAX(I) IF((IFMAT.GT.NBE).OR.(IFMAT.LT.1))GOTO 999 DO 10 J=IDMAT,IFMAT ITABRG(J) = IREFRG(I) 10 CONTINUE IDMAT = IFMAT+1 20 CONTINUE C IERR = 0 999 END C SUBROUTINE TBNUIT(ITABRG,NBE,IREFRG,NBREF,INUM, > ICARD,IERR) C ********************************************************************** C OBJET TBNUIT : DONNE UNE NUMEROTATION POUR OBTENIR DES INTERVALS C C EN ENTREE : C ITABRG : ITABRG(I) = LA VALEUR DE L'ELEMENT I C NBE : NOMBRE D'ELEMENTS C IREFRG : LES DIFFERENTES VALEURES DES ELEMENTS (-1 INTERDIT) C CHAQUE VALEUR DE ITABRG APPARAIT UNE ET UNE SEULE C FOIS DANS IREFRG C NBREF : NOMBRE DE VALEURES DIFFERENTES C C EN SORTIE : C INUM : INUM(I) = NOUVEAU NUMERO DE L'ELEMENT I C POUR OBTENIR DES INTERVALS. ILS SONT DANS L'ORDRE C DE IREFRG C ICARD : CARD(I) = CARDINAL DE LA REFERENCE IREFRG(I) C IERR : 0 SI OK C -1 SI IL MANQUE UNE REFERENCE, SI UNE REFERENCE EST DOUBLE. C *********************************************************************** INTEGER ITABRG(*),NBE,IREFRG(*),NBREF INTEGER INUM(*),ICARD(*),IERR C INTEGER I,J,IRENUM C IERR = -1 IF( NBREF.GT.NBE )THEN CALL DSERRE(1,IERR,'TBNUIT',' REFERENCES > ELEMENTS ') GOTO 999 ENDIF C ============================================ C --- 1. PARCOURS DE ITABRG C ON EMPILE LES NUMEROS DES ELEMENTS C D'UN MEME MATERIAU C ============================================ IRENUM = 0 DO 20 I=1,NBE INUM(I) = -1 20 CONTINUE DO 50 I=1,NBREF ICARD(I) = 0 DO 40 J=1,NBE IF( ITABRG(J).EQ.IREFRG(I))THEN IRENUM = IRENUM + 1 INUM(IRENUM) = J ICARD(I) = ICARD(I) + 1 ENDIF 40 CONTINUE 50 CONTINUE C IF( IRENUM.NE.NBE )THEN CALL DSERRE(1,IERR,'TBNUIT','ELEMENTS SANS REFERENCES') GOTO 999 ENDIF DO 60 I=1,NBE IF( INUM(I) .EQ. -1 )GOTO 999 60 CONTINUE C IERR = 0 C 999 END C SUBROUTINE TBVTAB(ITABRG,NBE,ITVL,IREFRG,NBREF, > NREFMX,IERR) C ********************************************************************** C OBJET TBVTAB : RENVOI LES VALEURS DISTINCTES ET TRIEES D'UN TABLEAU, C TRIEES DANS L'ORDRE CROISSANT C EN ENTREE : C ITABRG : UN ENSEMBLE DES REFERENCES C (PAR EXEMPLE ITABRG(I) = MATERIAU DE L'ELEMENT I) C NBE : NOMBRE DE REFERENCES C ITVL: TABLEAU DE TRAVAIL DE TAILLE = NBE C C IREFRG : TABLEAU RESULTAT (ON PEUT UTILISER ITABRG) C NREFMX: TAILLE DU TABLEAU RESULTAT C C EN SORTIE : C IREFRG : LES REFERENCES DISTINCTES DE IREFRG TRIEES DANS C L'ORDRE CROISSANT C NBREF : NOMBRE DE REFERENCES DISTINCTES (ON PEUT UTILISER NBE) C IERR : 0 SI OK C -2 SI IREFRG EST TROP PETIT C ********************************************************************** INTEGER ITABRG(*),NBE,IREFRG(*),NBREF,ITVL(*) INTEGER NREFMX,IERR C INTEGER I,IREF,NBREF2 C IREF = 1 DO 10 I=1,NBE ITVL(IREF-1+I) = ITABRG(I) 10 CONTINUE CALL KNUTA(NBE,ITVL(IREF)) NBREF2 = 1 IF(NREFMX.GT.0)THEN IREFRG(NBREF2) = ITVL(IREF) ELSE IERR = -2 ENDIF DO 20 I=2,NBE c IF( ITVL(I-1+IREF).NE.ITVL(NBREF2-1+IREF) ) BUG DU 10.10.98 IF( ITVL(I-1+IREF).NE.IREFRG(NBREF2) ) > NBREF2 = NBREF2+1 IF( NREFMX.GE.NBREF2 )THEN IREFRG(NBREF2) = ITVL(I-1+IREF) ELSE IERR = -2 ENDIF 20 CONTINUE C NBREF = NBREF2 C 999 END C ***************************************************************** C MODULE : ST (STRUCTURE DES DONNEES) C FICHIER : D3_ENSEMBLE.F C OBJET : MANIPULATION DES ENSEMBLES DE N-UPLETS (A FAIRE) C FONCT. : C C AUTEUR : O. STAB C DATE : 04.97 C MODIFICATIONS : C AUTEUR, DATE, OBJET : C C C *****************************************************************C C SUBROUTINE IORDR2(NBLIG,NBCOL,IORDRE,ITVL,NARG) C *************************************************************** C OBJET IORDR2: IMPOSE UN ORDRE DONNE A UN TABLEAU 2D D'ENTIERS C C IMPOSER UN ORDRE (FOURNI DANS LE TABLEAU IORDRE) A UN TABLEAU NARG C ITVL : TABLEAU DE TRAVAIL D'AU MOINS NBLIG ENTIERS C C EN ENTREE : C POUR I=1 A N, NARG(IORDRE(I)) EST LE I EME ARGUMENT DANS LA LISTE C ORDONNEE. IL OCCUPE DONC INITIALEMENT LA POSITION IORDRE(I). C C ATTENTION : IORDRE DOIT ETRE UNE PERMUTATION DES NBLIG ENTIERS C DE 1 A NBLIG. C C EN SORTIE : C POUR I=1 A NBLIG, NARG(I) EST LE I EME ARGUMENT DANS LA LISTE C ORDONNEE. IL OCCUPE DONC LA POSITION I CORESPONDANT A SON RANG. C POSONS J=IORDRE(J), ALORS NARG(ITVL(J)) EST MAINTENANT L'ARGUMENT C QUI INITIALEMENT ETAIT A LA POSITION J. C AUTREMENT DIT, LE TABLEAU M EST LA PERMUTATION RECIPROQUE DE L. C EN PARTICULIER, LES DEUX APPELS SUCCESSIFS SUIVANTS CONDUISENT C A LA FABRICATION DE ITVL (A PARTIR DE IORDRE) ET A NARG INCHANGE : C CALL IORDRE(NBLIG,NBCOL,IORDRE,ITVL,NARG) C PUIS CALL IORDRE(NBLIG,NBCOL,ITVL,IORDRE,NARG). C C *************************************************************** INTEGER NBLIG,NBCOL,IORDRE(*),ITVL(*),NARG(*) C INTEGER I,J,LI,MI,ITEMP C C ON N'A RIEN A FAIRE C IF(NBLIG.LE.1) GOTO 9999 C C PERMUTATION ITVL INVERSE DE IORDRE : C DO 10 I=1,NBLIG ITVL(IORDRE(I))=I 10 CONTINUE C C IMPOSER A NARG L'ORDRE DEFINI PAR IORDRE. C LES TABLEAUX IORDRE ET M SONT CASSES. C DO 20 I=1,NBLIG LI=IORDRE(I) MI=ITVL(I) C ---- ON PERMUTE 2 LIGNE ---- DO 40 J=1,NBCOL ITEMP=NARG((I-1)*NBCOL+J) NARG((I-1)*NBCOL+J)=NARG((LI-1)*NBCOL+J) NARG((LI-1)*NBCOL+J)=ITEMP 40 CONTINUE C --------------------------- IORDRE(MI)=LI ITVL(LI)=MI 20 CONTINUE C C RESTAURATION DES TABLEAUX L (INITIAL) ET M (SON INVERSE). C DO 30 I=1,NBLIG LI=IORDRE(I) MI=ITVL(I) IORDRE(MI)=I ITVL(LI)=I 30 CONTINUE 9999 END C C SUBROUTINE KNUTP2(N,L,ICOL,NBCOL,NARG) C *************************************************************** C OBJET KNUTP2: IDEM KNUTP FONCTIONNANT SUR DES TABLEAUX 2D C C EN ENTREE : C NARG : TABLEAU D'ENTIERS C N : NOMBRE DE LIGNES C NBCOL: NOMBRE DE COLONNES C ICOL : COLONNE A TRIER C C EN SORTIE : C L : INDICE DES ELEMENTS DE NARG TEL QUE C LA SUITE NARG((L(I)-1)*NBCOL+ICOL) SOIT ORDONNEE C C COMMENTAIRES KNUTP: C C ON TRIE LES N TERMES NARG(I) POUR I=1,N C C TRI PAR INCREMENT DECROISSANT (SHELL SORTING) C COMPLEXITE EN N PUISSANCE 3/2 ET MEME STATISTIQUEMENT EN N**1.2 C C POUR EN SAVOIR PLUS : KNUTH, "THE ART OF COMPUTER PROGRAMMING", C VOL 3 : SORTING AND SEARCHING, C ADDISON-WESLEY, 1973. C C KNUTP : P COMME PASSIF, C.A.D. QUE LES ARGUMENTS NARG(I) POUR C I=1 A N NE SONT PAS "PERMUTES" (TABLEAU NARG NON MODIFIE). C MAIS CE MODULE DETERMINE LE TABLEAU L(I) POUR I=1 A N C DE SORTE QUE LA SUITE NARG(L(I)) SOIT ORDONNEE. C VOIR AUSSI KNUTA. C C REMARQUE : NARG PEUT ETRE DE TOUT TYPE ET TOUTE LOI D'ORDRE C PEUT ETRE INTRODUITE. IL SUFFIT D'INTERVENIR C AUX ENDROITS INDIQUES AINSI : '***** ICI : ...'. C C *************************************************************** INTEGER N,L(*),NARG(*) INTEGER ICOL,NBCOL INTEGER NARGJ C INTEGER I,J,II,JJ,K,INCR C C ON N'A RIEN A TRIER C IF(N.LE.0) GOTO 9999 DO 10 I=1,N L(I)=I 10 CONTINUE IF(N.LE.1) GOTO 9999 C C POUR J=INCR+1,N, LA SOUS-SUITE NARG(L(J+H*INCR)), H=...,-3,-2,-1,0 C SERA ORDONNEE (TRI HABITUEL PAR INSERTION SEQUENTIELLE). C C DES QUE INCR=1 ON A ATTEINT L'OBJECTIF FINAL. C C INCR SUBIT UNE DECROISSANCE PROGRESSIVE DE SORTE QU'AU C DEBUT IL EST GRAND (LA SOUS-SUITE A TRIER A UN CARDINAL FAIBLE) C ENSUITE QUAND INCR DIMINUE LA PROFONDEUR DES PERMUTATIONS C NECESSAIRES RESTE LIMITEE GRACE AU TRI DE LA SOUS-SUITE C CORRESPONDANT A LA VALEUR PRECEDENTE DE L'INCREMENT (LE PAS). C INCR=N C C DECROISSANCE DE L'INCREMENT PAR DIVISION PAR 2 C 20 INCR=INCR/2 C C POUR TOUT J VARIANT DE INCR+1 A N, C LA SOUS-SUITE NARG(L(J+H*INCR)) AVEC H=...,-3,-2,-1,0 C SERA ORDONNEE. C DO 50 J=INCR+1,N C C ON PROCEDE PAR RECURENCE : LE FAIT QUE LES ELEMENTS C NARG(L(J+H*INCR)) DEPUIS LE DEBUT JUSQU'A J+H*INCR=K-INCR C SOIENT DEJA ORDONNES EST UTILISE POUR ALLER JUSTE PLACER C CONVENALEMENT L'ELEMENT L(K) : INSERTION SEQUENTIELLE. C JJ=L(J) C NARGJ=NARG(JJ) NARGJ=NARG((JJ-1)*NBCOL+ICOL) K=J DO 30 I=J-INCR,1,-INCR II=L(I) C C ***** ICI : LOI D'ORDRE C COMPARER NARG(II) ET NARGJ=NARG(JJ) C SI NARG(II) EST AVANT OU EGAL A NARGJ ALLER EN 40 C C IF(NARG(II).LE.NARGJ) GOTO 40 IF(NARG((II-1)*NBCOL+ICOL).LE.NARGJ) GOTO 40 C C DECALLAGE VERS LA DROITE DU I EME TERME C L(K)=II K=I 30 CONTINUE C C ON VIENT DE TROUVER LA PLACE CONVENABLE POUR NARG(L(J)) C 40 L(K)=JJ C C FIN DU TRI DE LA SOUS-SUITE ASSOCIEE A J C 50 CONTINUE C C PEUT-ON ENCORE DIMINUER L'INCREMENT (LE PAS) ? C IF(INCR.GT.1) GOTO 20 C C INCR=1, LE TRI FINAL EST ACHEVE. MERCI DE VOTRE VISITE. C 9999 END C C C SUBROUTINE TBILEX(ITB,NBN,NBE,NBO,NBT, > ITVL,NTIMAX, > ITBLEX,IERR) C ********************************************************************** C OBJET TBIMAG : TRI LEXICO D'UN TABLEAU D'ENTIER C C EN ENTREE : C ITB : TABLEAU DE NBN*NBE ENTIERS C NBN : NOMBRE D'ENTIER PAR ELEMENT (DE COLONNES) C NBE : NOMBRE D'ELEMENTS (DE LIGNES) C NBO : ORDRE DU TRI (<= NBN) C NBT : NOMBRE D'ELEMENTS A TRIER (<=NBE) C C ITVL : TABLEAU D'ENTIER (POUR LE TRAVAIL) C NTIMAX : LA TAILLE NECESSAIRE DEPEND DES DONNEES C AU MIN =1 : SI L'ORDRE 1 EST DISTINCTIF C AU MAX =3*NBE+NBO : SI 1 ERE COLONNE IDENTIQUE C ITBLEX : TABLEAU D'ENTIER DE TAILLE = NBE C C EN SORTIE : C ITBLEX : INDICE DES ELEMENTS DE ITB POUR QUE ITB(ITBLEX(I)) C SOIT TRIE DANS L'ORDRE CROISSANT LEXICOGRAPHIQUE C IERR : 0 SI OKAY C -2 ITVL TROP PETIT C C ********************************************************************** INTEGER ITB(*),NBN,NBE,NBO,NBT INTEGER ITVL(*),NTIMAX INTEGER ITBLEX(*),IERR C INTEGER ICOL,IED,IE,IV,NBE2,L2,ITRAV,J,IEMAX C IERR = 0 ICOL = 1 CALL KNUTP2(NBE,ITBLEX,ICOL,NBN,ITB) IF((NBO.EQ.1).OR.(NBN.EQ.1)) GOTO 9999 C IED = 1 C ========================================= C ---- ON PASSE A UN ELEMENT SUIVANT IED=IED+1 --- C ---- OU A L'ORDRE SUIVANT ICOL = ICOL+1 --- C ========================================= C IEMAX = NBE+1 IEMAX = 1 ITVL(ICOL-1+IEMAX) = NBE+1 20 CONTINUE IF( IED.GE.NBE )GOTO 9999 IE = IED IV = ITB((ITBLEX(IE)-1)*NBN+ICOL) 30 IE = IE + 1 C C --- TANT QUE LES ELEMENTS SONT IDENTIQUES A L'ORDRE ICOL --- IF((IE.LT.ITVL(ICOL-1+IEMAX)).AND. > (ITB((ITBLEX(IE)-1)*NBN+ICOL).EQ.IV))GOTO 30 C NBE2 = IE-IED C C --- ELEMENT UNIQUE : IL EST ORDONNE ! --- IF( NBE2.LE.1 )THEN * WRITE(6,*) IED,' DEJA DANS L ORDRE POUR LE NIVEAU ',ICOL IED = IE IF(( IED.EQ.NBT ).OR.( IED.EQ.NBE ))GOTO 9999 IF(IE.EQ.ITVL(ICOL-1+IEMAX))THEN * WRITE(6,*) IED,' ON A FINI LE NIVEAU ',ICOL C IEMAX = NBE + 1 C ICOL = 1 ICOL = ICOL - 1 ENDIF GOTO 20 ENDIF C C --- IL FAUT TRIER DE IED A IE SUR L'ORDRE :(ICOL+1) ---- * WRITE(6,*) 'TRI DE ',IED,' A ',(IE-1),' SUR L ORDRE ',(ICOL+1) C C L2 = NBE2 + ITRAV L2 = NBO + IEMAX ITRAV = L2 + NBE2 IF( (NTIMAX-ITRAV).LT.NBE2 )THEN IERR = -2 GOTO 9999 ENDIF DO 40 J=1,NBE2 ITVL(J-1+ITRAV) = ITB((ITBLEX(IED+J-1)-1)*NBN+ICOL+1) 40 CONTINUE * WRITE(6,*) 'COLONNE = ',(ITVL(J-1+ITRAV),J=1,NBE2) C CALL KNUTP(NBE2,ITVL(L2),ITVL(ITRAV)) * WRITE(6,*) 'ORDRE = ',(ITVL(L2+J-1),J=1,NBE2) C ---- MISE A JOUR DE ITBLEX ---- CALL IORDRE(NBE2,ITVL(L2),ITVL(ITRAV),ITBLEX(IED)) C IF(((ICOL+1).EQ.NBO).OR.((ICOL+1).EQ.NBN))THEN * WRITE(6,*) IED,' ON A FINI LE NIVEAU ',ICOL IED = IE ICOL = ICOL - 1 C IEMAX = NBE + 1 C ICOL = 1 IF(( IED.EQ.NBT ).OR.( IED.EQ.NBE ))GOTO 9999 GOTO 20 ENDIF ICOL = ICOL+1 ITVL(ICOL-1+IEMAX) = IE GOTO 20 C 9999 END C SUBROUTINE TBIMAG(ITB1,NBN1,NBE1,ITB2,NBN2,NBE2, > ITVL,NTIMAX, > IMAG1,IERR) C ********************************************************************** C OBJET TBIMAG : INDICES DES ELEMENTS COMMUNS DE 2 TABLEAUX C C EN ENTREE : C ITB1 : TABLEAU DE NBN1*NBE1 ENTIERS C NBN1 : NOMBRE D'ENTIER PAR ELEMENT (SANS ORDRE !) C NBE1 : NOMBRE D'ELEMENTS C ITB2,NBN2,NBE2 : IDEM C C ITVL : TABLEAU D'ENTIER (POUR LE TRAVAIL) C NTIMAX : LA TAILLE NECESSAIRE DEPEND DES DONNEES C AU MIN = NBE1+NBE2 : SI L'ORDRE 1 EST DISTINCTIF C AU MAX = 4*(NBE1+NBE2) : SI 1 ERE COLONNE IDENTIQUE C IMAG1 : TABLEAU D'ENTIER DE TAILLE = NBE C C EN SORTIE : C IMAG1 : IMAG(I) = EST LA POSITION DE L'ELEMENT I DE ITB1 DANS ITB2 C OU IMAG(I) = 0 SI L'ELEMENT N'EST PAS PRESENT DANS ITB2 C IERR : 0 SI OKAY C -2 ITVL TROP PETIT C C REMARQUE : C ATTENTION ITB1 ET ITB2 SONT MODIFIES C ********************************************************************** INTEGER ITB1(*),NBN1,NBE1,ITB2(*),NBN2,NBE2 INTEGER ITVL(*),NTIMAX INTEGER IMAG1(*),IERR C INTEGER IE,IT1,ITRAV,NITMX2,IT2,IE1,IE2,IETB1,IETB2,IDIFF,I,J C C --- TRI DES ENTIERS DE CHAQUE ELEMENT --- C DO 10 IE=1,NBE1 CALL KNUTA(NBN1,ITB1((IE-1)*NBN1+1)) 10 CONTINUE DO 20 IE=1,NBE2 CALL KNUTA(NBN2,ITB2((IE-1)*NBN2+1)) 20 CONTINUE C C --- TRI DES ELEMENTS --- C IT1 = 1 ITRAV = NBE1 + IT1 NITMX2 = NTIMAX - ITRAV IF( NITMX2.LE.0 )THEN IERR = -2 CALL DSERRE(1,IERR,'TBIMAG',' PAS DE PLACE') GOTO 9999 ENDIF CALL TBILEX(ITB1,NBN1,NBE1,NBN1,NBE1, > ITVL(ITRAV),NITMX2, > ITVL(IT1),IERR) C PRINT *,'TBIMAG : IT1 =', C > ((ITB1((ITVL(IE1-1+IT1)-1)*NBN1+J),J=1,NBN1),IE1=1,NBE1) IF( IERR.NE.0 )THEN CALL DSERRE(1,IERR,'TBIMAG',' 1 APPEL TBILEX') GOTO 9999 ENDIF IT2 = NBE1 + IT1 ITRAV = NBE2 + IT2 NITMX2 = NTIMAX - ITRAV CALL TBILEX(ITB2,NBN2,NBE2,NBN2,NBE2, > ITVL(ITRAV),NITMX2, > ITVL(IT2),IERR) C PRINT *,'TBIMAG : IT2 =', C > ((ITB2((ITVL(IE2-1+IT2)-1)*NBN2+J),J=1,NBN2),IE2=1,NBE2) IF( IERR.NE.0 )THEN CALL DSERRE(1,IERR,'TBIMAG',' 2 APPEL TBILEX') GOTO 9999 ENDIF C C --- COMPARAISON DES ELEMENTS --- C IE1 = 1 IE2 = 1 C C --- TANT QUE IE1 > IE2 : IE2 = IE2 + 1 C 40 CONTINUE IF( IE1.GT. NBE1 )GOTO 9999 IF( IE2.GT. NBE2 )THEN DO 50 I=IE1,NBE1 IMAG1(ITVL(I-1+IT1)) = 0 50 CONTINUE GOTO 9999 ENDIF IETB1 = ITVL(IE1-1+IT1) IETB2 = ITVL(IE2-1+IT2) DO 60 J=1,MAX(NBN1,NBN2) IDIFF = ITB1((IETB1-1)*NBN1+J)-ITB2((IETB2-1)*NBN2+J) IF( IDIFF.GT. 0)THEN IE2 = IE2 + 1 GOTO 40 ENDIF IF( IDIFF.LT. 0)THEN IE1 = IE1 + 1 GOTO 40 ENDIF 60 CONTINUE IMAG1(IETB1) = IETB2 IE1 = IE1 + 1 IE2 = IE2 + 1 GOTO 40 C 9999 END C C ***************************************************************** C MODULE : ST (STRUCTURE DES DONNEES) C FICHIER : ST_NUMERO.F C OBJET : RENUMEROTE UN MAILLAGE 2D OU 3D C FONCT. : C NUPERM : PERMUTE 2 ELEMENTS D'UN MAILLAGE C NURENU : RENUMEROTE LES ELEMENTS D'UN MAILLAGE C NUCOMP : RENUMEROTE LES ELEMENTS D'UN MAILLAGE POUR LES C COMPACTER EN DEBUT : DE 1 A "NBNUM" C C AUTEUR : O. STAB C DATE : 03.95 C TESTS : O.STAB 03.95 C MODIFICATIONS : C AUTEUR, DATE, OBJET : O.STAB, 08.97, NUPERM BUG_25 C C C ***************************************************************** C SUBROUTINE NUPERM(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI, > NOEMAX,NBE,IT1,IT2,IERR) C ***************************************************************** C OBJET : PERMUTE 2 ELEMENTS D'UN MAILLAGE C EN ENTREE: C IDE : (1..3) DIMENSION DES ELEMENTS (POURRA SERVIR) C ITRNOE: LES NOEUDS DES ELEMENTS C NBNMAX : (2..8) NOMBRE DE NOEUDS MAXIMUM DES ELEMENTS C ITRTRI: LES VOISINS DES ELEMENTS C NBCMAX : (2..6) NOMBRE DE COTES MAXIMUM DES ELEMENTS C NOEMAX: SI NOEMAX = 0 ALORS NOETRI N'EST PAS CONSIDERE C NBE : NOMBRE D'ELEMENTS DU MAILLAGE C IT1,IT2: LES 2 ELEMENTS A PERMUTER C EN SORTIE: C ITRNOE: MIS A JOUR C ITRTRI: MIS A JOUR C NOETRI : MIS A JOUR C IERR : CODE D'ERREUR 0 => OK C -1 => DONNEES INCOHERENTES C CONDITION D'APPLICATION : TOUT MAILLAGE C ***************************************************************** INTEGER IDE,ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX,NOETRI(*),NBE INTEGER NOEMAX,IT1, IT2, IERR C INTEGER I,J,K,ITRTR2(6),ITRNO2(8),IT(3),ITR,IFRINT INTEGER NNT,NTRTRI(2*6,3) C IERR = 0 IF( IT1 .EQ. IT2 )GO TO 999 IF((IT1.LT.1).OR.(IT1.GT.NBE).OR. > (IT2.LT.1).OR.(IT2.GT.NBE))THEN IERR = -1 CALL DSERRE(1,IERR,' NUPERM','NUMERO HORS INTERVAL') GO TO 999 ENDIF C ---- MISE A JOUR DES REFERENCES A IT1 ET IT2 --- IT(1) = IT1 IT(2) = IT2 IT(3) = IT1 NNT = 0 DO 10 K=1,2 IF( NOEMAX .GT. 0 )THEN C -- MISE A JOUR DES NOEUDS FAISANT REFERENCE A IT1,IT2 --- DO 20 I=1,NBNMAX C IF( NOETRI(ITRNOE((IT(K)-1)*NBNMAX+I)) .EQ. IT(K) ) C BUG_25 : IL FAUT TESTER LE NUMERO DU NOEUD !!! C MAILLAGE MIXTE OU ELEMENTS VIDE (A CREER) IF(( ITRNOE((IT(K)-1)*NBNMAX+I) .NE. 0 ).AND. > ( NOETRI(ITRNOE((IT(K)-1)*NBNMAX+I)) .EQ. IT(K) )) > NOETRI(ITRNOE((IT(K)-1)*NBNMAX+I)) = IT(K+1) 20 CONTINUE ENDIF C --- DEBUT AJOUT DU 14.08.97 O.STAB ---------------------- C POUR POUVOIR TRAITER SEULEMENT ITRNOE, PAS ITRTRI = 0 C TRIVIAL MAIS PERMET D'UTILISER LES MEMES FONCTIONS C IF( NBCMAX .EQ. 0 )THEN DO 21 I=1,NBNMAX ITRNO2(I)=ITRNOE((IT2-1)*NBNMAX+I) 21 CONTINUE DO 22 I=1,NBNMAX ITRNOE((IT2-1)*NBNMAX+I)=ITRNOE((IT1-1)*NBNMAX+I) 22 CONTINUE DO 23 I=1,NBNMAX ITRNOE((IT1-1)*NBNMAX+I)=ITRNO2(I) 23 CONTINUE GOTO 999 ENDIF C --- FIN AJOUT DU 14.08.97 O.STAB ------------------------ C C ---- MISE A JOUR DES ELEMENTS VOISINS DE IT1,IT2 --- DO 30 I=1,NBCMAX ITR = ITRTRI((IT(K)-1)*NBCMAX+I) IF((ITR.NE.0).AND.(ITR.NE.IT(K+1)) > .AND.(ITR.NE.-IT(K+1)))THEN IFRINT = 1 IF( ITR .LT. 0 )THEN IFRINT = -1 ITR = - ITR ENDIF DO 40 J=1,NBCMAX IF( (ITRTRI((ITR-1)*NBCMAX+J).EQ.IT(K)) .OR. > (ITRTRI((ITR-1)*NBCMAX+J).EQ.-IT(K)) )THEN NNT = NNT + 1 NTRTRI(NNT,1) = ITR NTRTRI(NNT,2) = J NTRTRI(NNT,3) = IFRINT * IT(K+1) C ITRTRI((ITR-1)*NBCMAX+J) = IFRINT * IT(K+1) GO TO 30 ENDIF 40 CONTINUE C --- IL Y A UN BUG DANS LA STRUCTURE --- IERR = -1 CALL DSERRE(1,IERR,' NUPERM',' STRUCTURE MAILLAGE') GO TO 999 ENDIF 30 CONTINUE 10 CONTINUE C ------------------ MIS AJOUR DES VOISINS DE IT1,IT2 --- DO 45 I=1,NNT ITRTRI((NTRTRI(I,1)-1)*NBCMAX+NTRTRI(I,2))=NTRTRI(I,3) 45 CONTINUE C ------------------ SAUVEGARDE IT2 --- DO 50 I=1,NBCMAX IF( ITRTRI((IT2-1)*NBCMAX+I) .EQ. IT1 )THEN ITRTR2(I)=IT2 ELSE IF( ITRTRI((IT2-1)*NBCMAX+I).EQ.-IT1)THEN ITRTR2(I)=-IT2 ELSE ITRTR2(I)=ITRTRI((IT2-1)*NBCMAX+I) ENDIF 50 CONTINUE DO 60 I=1,NBNMAX ITRNO2(I)=ITRNOE((IT2-1)*NBNMAX+I) 60 CONTINUE C ---------- TRANSFERT IT1 -> IT2 ---------- DO 70 I=1,NBCMAX IF( ITRTRI((IT1-1)*NBCMAX+I) .EQ. IT2 )THEN ITRTRI((IT2-1)*NBCMAX+I)=IT1 ELSE IF( ITRTRI((IT1-1)*NBCMAX+I) .EQ. -IT2 )THEN ITRTRI((IT2-1)*NBCMAX+I)=-IT1 ELSE ITRTRI((IT2-1)*NBCMAX+I)=ITRTRI((IT1-1)*NBCMAX+I) ENDIF 70 CONTINUE DO 80 I=1,NBNMAX ITRNOE((IT2-1)*NBNMAX+I)=ITRNOE((IT1-1)*NBNMAX+I) 80 CONTINUE C ---------- TRANSFERT IT2 -> IT1 ---------- DO 90 I=1,NBCMAX ITRTRI((IT1-1)*NBCMAX+I)=ITRTR2(I) 90 CONTINUE DO 100 I=1,NBNMAX ITRNOE((IT1-1)*NBNMAX+I)=ITRNO2(I) 100 CONTINUE C ------------------ 999 END C SUBROUTINE NURENU(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI, > NOEMAX,NBE,NUM,ITRAMA,IERR) C ***************************************************************** C OBJET : RENUMEROTE LES ELEMENTS D'UN MAILLAGE C EN ENTREE: C IDE : (1..3) DIMENSION DES ELEMENTS C ITRNOE: LES NOEUDS DES ELEMENTS C NBNMAX : (2..8) NOMBRE DE NOEUDS MAXIMUM DES ELEMENTS C ITRTRI: LES VOISINS DES ELEMENTS C NBCMAX : (2..6) NOMBRE DE COTES MAXIMUM DES ELEMENTS C NOEMAX: SI NOEMAX = 0 ALORS NOETRI N'EST PAS CONSIDERE C NBE : NOMBRE D'ELEMENTS DU MAILLAGE C NUM : NUM(I) EST NUMERO DE ELEMENTS QUI DOIT ETRE MIS EN I C ITRAMA : " " " " DE TAILLE = NBE C EN SORTIE: C ITRNOE: MIS A JOUR C ITRTRI: MIS A JOUR C NOETRI : MIS A JOUR C CONDITION D'APPLICATION : TOUT MAILLAGE C REMARQUE : COPIE DE IORDRE DE S.M. TIJANI C ***************************************************************** INTEGER IDE,ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX,NOETRI(*),NBE INTEGER NOEMAX, NUM(*), ITRAMA(*), IERR C C ---- COPIE DE IORDRE (S.M.TIJANI )---- C INTEGER I,LI,MI C C ON N'A RIEN A FAIRE C IERR = 0 IF(NBE.LE.1) GOTO 9999 C C PERMUTATION M INVERSE DE L : C DO 10 I=1,NBE ITRAMA(NUM(I))=I 10 CONTINUE C C IMPOSER A NARG L'ORDRE DEFINI PAR L. C LES TABLEAUX L ET M SONT CASSES. C DO 20 I=1,NBE LI=NUM(I) MI=ITRAMA(I) CALL NUPERM(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI, > NOEMAX,NBE,I,LI,IERR) IF( IERR .LT. 0 )GO TO 9999 NUM(MI)=LI ITRAMA(LI)=MI 20 CONTINUE C C RESTAURATION DES TABLEAUX L (INITIAL) ET M (SON INVERSE). C DO 30 I=1,NBE LI=NUM(I) MI=ITRAMA(I) NUM(MI)=I ITRAMA(LI)=I 30 CONTINUE 9999 END C C SUBROUTINE NUCOMP(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI, > NOEMAX,NBE,NUM,NBNUM,IERR) C ***************************************************************** C OBJET : RENUMEROTE LES ELEMENTS D'UN MAILLAGE POUR LES COMPACTER C EN DEBUT : DE 1 A "NBNUM" C EN ENTREE: C IDE : (1..3) DIMENSION DES ELEMENTS C ITRNOE: LES NOEUDS DES ELEMENTS C NBNMAX : (2..8) NOMBRE DE NOEUDS MAXIMUM DES ELEMENTS C ITRTRI: LES VOISINS DES ELEMENTS C NBCMAX : (2..6) NOMBRE DE COTES MAXIMUM DES ELEMENTS C NBE : NOMBRE D'ELEMENTS DU MAILLAGE C NOEMAX: SI NOEMAX = 0 ALORS NOETRI N'EST PAS CONSIDERE C NUM : NUM(I) EST NUMERO DE L'ELEMENT QUI DOIT ETRE MIS EN I C ATTENTION !! NUM DOIT ETRE TRIE AVEC ENSTRI C NBNUM : NOMBRE D'ELEMENTS A RENUMEROTER C EN SORTIE: C ITRNOE: MIS A JOUR C ITRTRI: MIS A JOUR C NOETRI : MIS A JOUR C CONDITION D'APPLICATION : TOUT MAILLAGE C COMPLEXITE : O(NBNUM) ALORS QUE STRRENUM EST EN O(NBE) C PRINCIPE : LES PERMUTATIONS FONCTIONNENT SI NUM(I)>I C C.A.D. L'ANCIENNE POSITION > A LA NOUVELLE C ON EST DANS CE CAS SI NUM EST TRIE PAR ORDRE CROISS. C ***************************************************************** INTEGER IDE,ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX,NOETRI(*),NBE INTEGER NOEMAX,NUM(*),NBNUM,IERR C INTEGER I C DO 10 I=1,NBNUM CALL NUPERM(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI, > NOEMAX,NBE,NUM(I),I,IERR) IF( IERR .NE. 0 )GOTO 999 10 CONTINUE 999 END C ********************************************************************** C FICHIER : ST_MEMOIRE.F C OBJET : NOMBRE MAXIMUM DE POINTS ET D'ELEMENTS (DU MAILLAGE) C EN FONCTION DE LA MEMOIRE DISPONIBLE ET DU TRAITEMENT C C FONCT. : C OBJET MEMOMX : NBRE MAXIMUM DE NOEUDS ET D'ELEMENTS EN FCT MEMOIRE C OBJET DS4MAX : RENVOI LE NOMBRE MAXIMUM DE POINTS ET D'ELEMENTS C OBJET DSGMAX : RENVOI LE NOMBRE MAXIMUM DE POINTS ET D'ELEMENTS C OBJET DS1MAX : RENVOI LE NOMBRE MAXIMUM DE POINTS ET D'ELEMENTS C C AUTEUR : O. STAB C DATE : 10.10.98 C TESTS : C MODIFICATIONS : C AUTEUR, DATE, OBJET : O.STAB, 28.07.99, EXTRAIT DE DS1, DS4... C AUTEUR, DATE, OBJET : O.STAB, 02.02.05, modif DS4MAX ajout de 50 C points pour la triangulation C AUTEUR, DATE, OBJET : O.STAB, 26.05.05, modif DSGMAX,DS4MAX C NBEMAX quand NBTOT=0 ! C C A FAIRE : REFLECHIR SUR L'INTERET DE METTRE DANS L'API ! C ********************************************************************** C SUBROUTINE MEMOMX(NITMAX,NRTMAX,NI,NR,TI,TR,NBPMAX,NBEMAX,IERR) C ********************************************************************** C OBJET MEMOMX : NBRE MAXIMUM DE NOEUDS ET D'ELEMENTS EN FCT MEMOIRE C C EN ENTREE : C NITMAX : NOMBRE D'ENTIERS DISPONIBLES C NRTMAX : NOMBRE DE REELS DISPONIBLES C NI : NOMBRE D'ENTIERS PAR NOEUD C NR : NOMBRE DE REELS PAR NOEUD C TI : NOMBRE D'ENTIERS PAR TRIANGLE C TR : NOMBRE DE REELS PAR TRIANGLES C C EN SORTIE : C NBPMAX : NOMBRE MAXIMUM DE POINTS (OU -1 SI INDEFINI) C NBEMAX : NOMBRE MAXIMUM DE TRIANGLES (OU -1 SI INDEFINI) C IERR : 0 => OK, -1 => ERREUR DANS LES DONNEES C C REMARQUE : 2 EQUATIONS 2 INCONNUES : C (1) NITMAX = NI * NBPMAX + TI * NBEMAX C (2) NRTMAX = NR * NBPMAX + TR * NBEMAX C ********************************************************************** INTEGER NITMAX,NRTMAX,NI,NR,TI,TR INTEGER NBPMAX,NBEMAX,IERR C INTEGER IDENOM C IERR = 0 NBEMAX = -1 NBPMAX = -1 C ---- ON A QU'UNE EQUATION AVEC UNE INCONNUE ---- IF(( TI.EQ. 0 ).AND.( TR.EQ.0 ))THEN IF(( NI.GT. 0 ).AND.( NR.GT.0 ))THEN NBPMAX = MIN(NITMAX/NI,NRTMAX/NR) ELSE IF( NI.GT. 0 )THEN NBPMAX = NITMAX/NI ELSE IF( NR.GT. 0 )THEN NBPMAX = NRTMAX/NR ENDIF ENDIF ENDIF GOTO 9999 ENDIF C ---- ON A QU'UNE EQUATION AVEC UNE INCONNUE ---- IF(( NI.EQ. 0 ).AND.( NR.EQ.0 ))THEN IF(( TI.GT. 0 ).AND.( TR.GT.0 ))THEN NBEMAX = MIN(NITMAX/TI,NRTMAX/TR) ELSE IF( NI.GT. 0 )THEN NBEMAX = NITMAX/TI ELSE IF( NR.GT. 0 )THEN NBEMAX = NRTMAX/TR ENDIF ENDIF ENDIF GOTO 9999 ENDIF C IDENOM = TR * NI - TI * NR IF( IDENOM.EQ. 0 )THEN C ON MAJORE : NBEMAX = 2 * NBPMAX ET ON RESOUD. IERR = -1 CALL DSERRE(1,IERR,'MMTRMX',' LES EQUATIONS SONT LIEES ') GOTO 9999 ENDIF NBPMAX = ( NITMAX * TR - NRTMAX * TI ) / IDENOM C NBEMAX = ( NRTMAX * NI - NITMAX * NR ) / IDENOM C C PRINT *,'NITMAX,NRTMAX,NI,NR,TI,TR = ',NITMAX,NRTMAX,NI,NR,TI,TR C PRINT *,'NBPMAX, NBEMAX = ',NBPMAX,NBEMAX C 9999 END C C SUBROUTINE DS4MAX(IDIMC,NMT,NBN,NBE,NBPTOT, > PSTRUC,PITRRG,TSN,ICOEF,IDIMG, > NITMAX,NRTMAX, > NBPMAX,NBEMAX,IERR) C ********************************************************************** C OBJET DS4MAX : RENVOI LE NOMBRE MAXIMUM DE POINTS ET D'ELEMENTS C ********************************************************************** INTEGER IDIMC,NMT,NBN,NBE,NBPTOT,NITMAX,NRTMAX INTEGER PSTRUC,PITRRG,TSN,ICOEF,IDIMG INTEGER NBPMAX,NBEMAX,IERR C INTEGER NI,NR,TI,TR,NITMX2 INTEGER IMEMAT,NBNMAX,NBCMAX,IDE C NBNMAX = 3 NBCMAX = 3 IDE = 2 IERR = 0 C ======================= C --- 1.1. ALLOCATION --- C ======================= C ETAPE 1 : C ------- C ALLOCATION DU TABLEAU D'ENTIERS C POINTEURS : IREFRG | INTMAT | ITRNOE | ITRTRI | NOETRI C TAILLES : NMT , NMT , NBEMAX , NBEMAX , NBPMAX C C ALLOCATION DU TABLEAU DE REELS C POINTEURS : ICOORD | C TAILLES : NBPMAX C C ETAPE 2 : CAS MULTI-REGIONS, 1 SEUL ENTIER (HOMOGENE) C ------- C ALLOCATION DU TABLEAU D'ENTIERS C POINTEURS : ...NOETRI | ITRIRG | IFR | IMATFR C TAILLES : , NBEMAX , 2*NBIFR, 2*NBIFR C C ETAPE 4 : CAS MULTI-REGIONS C ------- C ALLOCATION DU TABLEAU D'ENTIERS C POINTEURS : ...IMATFR | ITRIRG C TAILLES : , NBEMAX C C ALLOCATION DU TABLEAU DE REELS C POINTEURS : ICOORD | ITBDEN C TAILLES : , NBPMAX C C C NOETRI + ITBDEN NI = 1 + 1 C ICOORD + ICOORD (RFITER) + TSN NR = IDIMC + IDIMC + 1 C STRUCTURE ET REGIONS C ITRNOE + ITRTRI + (ITRIRG + IFR + IMATFR) + ITRIRG IMEMAT = 1 + 2 + 2 IF( NMT.EQ.1 )IMEMAT = 0 TI = NBNMAX + NBCMAX + IMEMAT + 1 C ISPHER + COEF TR = IDE+1 + 1 C C ---- NOMBRE DE NOEUDS FIXES PAR LA CAPACITE MEMOIRE --- C IF( NBPTOT.EQ.-1 )THEN NITMX2 = NITMAX - 2 * NMT CALL MEMOMX(NITMX2,NRTMAX,NI,NR,TI,TR,NBPMAX,NBEMAX,IERR) IF( IERR.NE. 0 )THEN CALL DSERRE(1,IERR,'DS4ESF',' APPEL MEMOMX ') C PRINT *,'NI,NR,TI,TR = ',NI,NR,TI,TR GOTO 9999 ENDIF NBEMAX = MIN(NBEMAX,2*NBPMAX-2) C --- POUR CHAQUE NOEUD AJOUTE ON CREE 2 ELEMENTS ! NBPMAX = MIN((NBEMAX - NBE ) / 2 + NBN, NBPMAX) C PRINT *,'NBEMAX, NBPMAX = ',NBEMAX,NBPMAX ENDIF C C ---- PAS DE NOUVEAUX NOEUDS ---- C IF( NBPTOT.EQ.0 )THEN NBPMAX = NBN C NBEMAX = NBE <- c'est un maillage lineique !!!! C bug corrige 23.05.2005 t=2n-2-a' NBEMAX = NBN*2 -5 ENDIF C C ---- NOMBRE TOTAL DE NOEUDS ATTEINT ---- C IF(( NBPTOT.GT.0 ).AND.( NBPTOT.LT.NBN ))THEN IERR = -1 CALL DSERRE(1,IERR,'DS4ESF','MAXIMUM DEJA ATTEINT') GOTO 9999 ENDIF C C ---- NOMBRE TOTAL DE NOEUDS IMPOSES ---- C IF( NBPTOT.GE.NBN )THEN C ajout 01.02.2005 : il faut faire de la place pour les triangles bidons ! NBPMAX = NBPTOT+50 NBEMAX = MIN((NITMAX - NI * NBPMAX ) / TI, > (NRTMAX - NR * NBPMAX ) / TR ) NBEMAX = MIN(NBEMAX,2*NBPMAX-2) ENDIF C 9999 END C SUBROUTINE DSGMAX(IDIMC,NMT,NBN,NBE,NBPTOT, > PSTRUC,PITRRG,TSN,ICOEF,IDIMG, > NITMAX,NRTMAX, > NBPMAX,NBEMAX,IERR) C ********************************************************************** C OBJET DSGMAX : RENVOI LE NOMBRE MAXIMUM DE POINTS ET D'ELEMENTS C EN ENTREE : C NBN,NBE,NMT : MAILLAGE LINEIQUE C EN SORTIE : NBPMAX, NBEMAX : POUR UN MAILLAGE TRIANGULAIRE C ********************************************************************** INTEGER IDIMC,NMT,NBN,NBE,NBPTOT,NITMAX,NRTMAX INTEGER PSTRUC,PITRRG,TSN,ICOEF,IDIMG INTEGER NBPMAX,NBEMAX,IERR C INTEGER NI,NR,TI,TR INTEGER NITMX2 INTEGER IPROJ,IEXTR INTEGER IMEMAT,NBNMAX,NBCMAX,IDE C NBNMAX = 3 NBCMAX = 3 IDE = 2 IERR = 0 IPROJ = 0 IF(IDIMC.EQ.3)IPROJ = 1 IEXTR = 0 IF(NMT.GT.1)IEXTR = 1 C -------- POUR LES ENTIERS -------------------------- C POUR LE MAILLAGE TRIANGULAIRE : C NISIZE = NBNMAX*NBE + NBCMAX*NBE + NBN + NBE C ITRNOE | ITRTRI | NOETRI | ITRIRG C AUQUEL S'AJOUTE LES ARETES : C = NBARET*2 + NBARET*2 C IARET | IAR2RG C NBARET < 3*NBE : MAIS ON PEUT FAIRE L'HYPOTHESE : NBARET = NBE C C -------- POUR LES REELS -------------------------- C POUR LE MAILLAGE TRIANGULAIRE : (POUR LES CERCLE) C NRSIZE = NBN*TSN + NBN*IDIMC + NBN*IDIMG + NBN*IPROJ + NBN*IEXTR + NBE *3 C C ---- ENTIERS PAR NOEUDS : NOETRI + ITBDEN NI = 1 + 1 C C --- DANS LE CAS POINTS SEULEMENT ON NE RAFFINE PAS ?? --- C ---- REELS PAR NOEUDS : C ICOORD + ICOORD (RFITER) + TSN NR = 2*IDIMC + IDIMG + TSN + IPROJ + IEXTR C C ---- POUR LES TRIANGLES : C TI = NBNMAX + PSTRUC*NBCMAX + PITRRG + (IARET+IAR2RG) TI = NBNMAX + PSTRUC*NBCMAX + PITRRG + 4 C ISPHER + COEF TR = 3 + 1 C IF( NBPTOT.EQ.-1 )THEN NITMX2 = NITMAX - 2 * NMT CALL MEMOMX(NITMX2,NRTMAX,NI,NR,TI,TR,NBPMAX,NBEMAX,IERR) IF( IERR.NE. 0 )THEN CALL DSERRE(1,IERR,'DSGMAX',' APPEL MEMOMX ') C PRINT *,'NI,NR,TI,TR = ',NI,NR,TI,TR GOTO 9999 ENDIF NBEMAX = MIN(NBEMAX,2*NBPMAX-2) C --- POUR CHAQUE NOEUD AJOUTE ON CREE 2 ELEMENTS ! NBPMAX = MIN((NBEMAX - NBE ) / 2 + NBN, NBPMAX) C PRINT *,'NBEMAX, NBPMAX = ',NBEMAX,NBPMAX ENDIF C C ---- PAS DE NOUVEAUX NOEUDS ---- C IF( NBPTOT.EQ.0 )THEN NBPMAX = NBN C NBEMAX = NBE <- c'est un maillage lineique !!!! C bug corrige 23.05.2005 t=2n-2-a' NBEMAX = NBN*2 -5 ENDIF C C ---- NOMBRE TOTAL DE NOEUDS ATTEINT ---- C IF(( NBPTOT.GT.0 ).AND.( NBPTOT.LT.NBN ))THEN IERR = -1 CALL DSERRE(1,IERR,'DSGMAX','MAXIMUM DEJA ATTEINT') GOTO 9999 ENDIF C C ---- NOMBRE TOTAL DE NOEUDS IMPOSES ---- C IF( NBPTOT.GT.NBN )THEN NBPMAX = NBPTOT NBEMAX = MIN((NITMAX - NI * NBPMAX ) / TI, > (NRTMAX - NR * NBPMAX ) / TR ) NBEMAX = MIN(NBEMAX,2*NBPMAX-2) ENDIF C 9999 END C C SUBROUTINE DS1MAX(IDIMC,NMT,NBN,NBE,NBPTOT, > PSTRUC,PITRRG,TSN,ICOEF,IDIMG, > NITMAX,NRTMAX, > NBPMAX,NBEMAX,IERR) C ********************************************************************** C OBJET DS1MAX : RENVOI LE NOMBRE MAXIMUM DE POINTS ET D'ELEMENTS C ********************************************************************** INTEGER IDIMC,NMT,NBN,NBE,NBPTOT,NITMAX,NRTMAX INTEGER PSTRUC,PITRRG,TSN,ICOEF,IDIMG INTEGER NBPMAX,NBEMAX,IERR C INTEGER NI,NR,TI,TR INTEGER IMEMAT,NBNMAX,NBCMAX,IDE C NBNMAX = 0 NBCMAX = 0 IF( NBE.GT.0 )THEN NBNMAX = 2 NBCMAX = 2 ENDIF IDE = 1 IERR = 0 C C C NISIZE = NBNMAX*NBE + NBCMAX*NBE + NBN + NBE C ITRNOE | ITRTRI | NOETRI | ITRIRG NI = PSTRUC C --- DANS LE CAS POINTS SEULEMENT ON NE RAFFINE PAS --- NR = IDIMC + IDIMG IF(NBE.GT.0)NR = 2*IDIMC + IDIMG + TSN + 1 TI = NBNMAX + PSTRUC*NBCMAX + PITRRG TR = ICOEF C IF( NBPTOT.EQ.-1 )THEN C NBPMAX = NBN + (NBEMAX-NBE) C NITMX2 = NBPMAX*NI + NBEMAX*TI C NRTMX2 = NBPMAX*NR + NBEMAX*TR CALL MEMOMX(NITMAX,NRTMAX,NI,NR,TI,TR,NBPMAX,NBEMAX,IERR) IF( IERR.NE.0 )THEN CALL DSERRE(1,IERR,'DS1MEM','APPEL MEMOMX ') GOTO 9999 ENDIF C NBPMAX = NRTMX2 / NR C NBEMAX = ( NITMX2 - NBN*NI + NBE*NI ) / (NI + TI) IF( NBEMAX.LT.0 )THEN IF(NBE.EQ.0)THEN NBEMAX = 0 ELSE IERR = -1 CALL DSERRE(1,IERR,'DS1MEM','NBEMAX INDETERMINE ') GOTO 9999 ENDIF ENDIF NBPMAX = MIN( NBPMAX, NBN + (NBEMAX-NBE)) NBEMAX = MIN( NBEMAX, NBE + (NBPMAX-NBN)) C PRINT *,'NBPMAX, NBEMAX = ',NBPMAX,NBEMAX ENDIF IF( NBPTOT.EQ.0 )THEN NBPMAX = NBN NBEMAX = NBE ENDIF IF( NBPTOT.GT.NBN )THEN NBPMAX = NBPTOT NBEMAX = ( NITMAX - NBN*NI + NBE*NI ) / (NI + TI) NBEMAX = MIN(NBEMAX, NBE + (NBPMAX-NBN)) ENDIF C NISIZE = NBNMAX*NBE + NBCMAX*NBE + NBN + NBE C ITRNOE | ITRTRI | NOETRI | ITRIRG C NBCMAX = NBNMAX C NISIZE = NBNMAX + NBCMAX*PSTRUC + PSTRUC + PITRRG C DANS R1ITER ON COPIE LES COORDONNEES : 2 * IDIMC + COEF C DANS R1DIR ON CALCULE TOUS LES POINTS SUR UN SEGMENT. C SI TAILLE SOUHAITE AUX NOEUDS : IRADEC + NBPMAX C D'OU : C NBPMAX = (NRTMAX - IRTRAV)/ (2*IDIMC+IDIMG+1+1) C NBPNEW EST UNE BORNE SUPERIEURE QUAND ELLE EST DONNEE C IF( NBPNEW.GE. 0 )NBPMAX = MIN( NBPNEW+NBN ,NBPMAX ) C NBPMAX = MIN( ((NITMAX - ITRAV) / NISIZE), NBPMAX) 9999 END C C ***************************************************************** C MODULE : ST (STRUCTURE DES DONNEES) C FICHIER : ST_NOEUD.F C OBJET : RENUMEROTE LES NOEUDS D'UN MAILLAGE 2D OU 3D C FONCT. : C C OBJET NUNONU : RENUMEROTE LES NOEUDS D'UN MAILLAGE C OBJET NUNOCP : COMPRIME LES NUMEROS DES NOEUDS D'UN MAILLAGE C OBJET EN DEBUT : DE 1 A "NBNUM" C OBJET NUNISO : RENUMEROTATION, LES NOEUDS ISOLES SONT MIS EN FIN C OBJET NUENUL : RENUMEROTATION, LES ELEMENTS NULS SONT MIS EN FIN C OBJET NUGCNU : GARBAGE COLLECTOR ELEMENTS ET POINTS C C AUTEUR : O. STAB C DATE : 08.96 C TESTS : C MODIFICATIONS : C AUTEUR, DATE, OBJET : C C C ***************************************************************** C C SUBROUTINE NUNONU(ITRNOE,NBNMAX,NOETRI,NOEMAX,NBE, > COORD,IDIMC, > NUM,NBNUM,ITRAMA,IERR) C ***************************************************************** C OBJET NUNONU : RENUMEROTE LES NOEUDS D'UN MAILLAGE C C EN ENTREE: C ITRNOE,NBNMAX,NBE,NOETRI,NOEMAX : LE MAILLAGE C NBNMAX: SI NBNMAX = 0 ALORS ITRNOE N'EST PAS CONSIDERE C NOEMAX: SI NOEMAX = 0 ALORS NOETRI N'EST PAS CONSIDERE C C C COORD,IDIMC : COORDONNEES DES NOEUDS C IDIMC : SI IDIMC = 0 ALORS COORD N'EST PAS CONSIDERE C C NUM : NUM(I) EST NUMERO DE L'ELEMENT QUI DOIT ETRE MIS EN I C ATTENTION !! NUM DOIT ETRE TRIE AVEC ENSTRI C NBNUM : NOMBRE DE NOEUDS A RENUMEROTER C ITRAMA : TABLEAU DE TRAVAIL DE TAILLE = MAX(NUM(I)) C C EN SORTIE: C ITRNOE : MIS A JOUR C NOETRI : MIS A JOUR C COORD : MIS A JOUR C C CONDITION D'APPLICATION : TOUT MAILLAGE C REMARQUE : COPIE DE IORDRE DE S.M. TIJANI C ***************************************************************** INTEGER ITRNOE(*),NBNMAX,NOETRI(*),NBE REAL COORD(*) INTEGER IDIMC INTEGER NOEMAX, NUM(*), NBNUM, ITRAMA(*), IERR C C ---- COPIE DE IORDRE (S.M.TIJANI )---- C INTEGER I,J,LI,MI INTEGER NUMOLD,ITAMPO REAL RTAMPO C C ON N'A RIEN A FAIRE C IERR = 0 C ----- modif o.stab : 03/04/2003 COMMENT CE BUG est-il reste la ??!! C APPEL ds NUGCNU qui est appele : dans blocos.f, hexos.f et sm_smooth C ----- modif o.stab : 03/04/2003 NUM est remplace par ITRAMA !!! C IF(NBNUM.LE.1) GOTO 9999 C C DO 20 I=1,NBE C ----------------------------------- C --- MISE A JOUR DES NOEUDS DES ELEMENTS --- C ----------------------------------- C DO 10 J=1,NBNMAX C NUMOLD = ITRNOE((I-1)*NBNMAX + J) C IF((NUMOLD.GT.0 ).AND.(NUMOLD.LE.NBNUM))THEN C ITRNOE((I-1)*NBNMAX + J) = NUM(NUMOLD) C ENDIF C 10 CONTINUE C 20 CONTINUE C C PERMUTATION M INVERSE DE L : C DO 30 I=1,NBNUM ITRAMA(NUM(I))=I 30 CONTINUE C DO 20 I=1,NBE C ----------------------------------- C --- MISE A JOUR DES NOEUDS DES ELEMENTS --- C ----------------------------------- DO 10 J=1,NBNMAX NUMOLD = ITRNOE((I-1)*NBNMAX + J) IF((NUMOLD.GT.0 ).AND.(NUMOLD.LE.NBNUM))THEN ITRNOE((I-1)*NBNMAX + J) = ITRAMA(NUMOLD) ENDIF 10 CONTINUE 20 CONTINUE C IMPOSER A NARG L'ORDRE DEFINI PAR L. C LES TABLEAUX L ET M SONT CASSES. C DO 50 I=1,NBNUM LI=NUM(I) MI=ITRAMA(I) C ---------------------- C --- PERMUTATION DES NOEUDS --- C ---------------------- IF( NOEMAX.NE.0)THEN ITAMPO = NOETRI(I) NOETRI(I) = NOETRI(LI) NOETRI(LI) = ITAMPO ENDIF DO 40 J=1,IDIMC RTAMPO = COORD((I-1)*IDIMC+J) COORD((I-1)*IDIMC+J) = COORD((LI-1)*IDIMC+J) COORD((LI-1)*IDIMC+J) = RTAMPO 40 CONTINUE C C LE NOUVEAU NUMERO DE LI EST I C LE NOUVEAU NUMERO DE MI A CHANGE, C'EST DEVENU LI C NUM(MI)=LI ITRAMA(LI)=MI 50 CONTINUE C C RESTAURATION DES TABLEAUX L (INITIAL) ET M (SON INVERSE). C DO 60 I=1,NBE LI=NUM(I) MI=ITRAMA(I) NUM(MI)=I ITRAMA(LI)=I 60 CONTINUE 9999 END C C SUBROUTINE NUNOCP(ITRNOE,NBNMAX,NOETRI,NOEMAX,NBE, > COORD,IDIMC, > NUM,NBNUM,IERR) C ***************************************************************** C OBJET NUNOCP : COMPRIME LES NUMEROS DES NOEUDS D'UN MAILLAGE C OBJET EN DEBUT : DE 1 A "NBNUM" C C EN ENTREE: C ITRNOE,NBNMAX,NBE,NOETRI,NOEMAX : LE MAILLAGE C NBNMAX: SI NBNMAX = 0 ALORS ITRNOE N'EST PAS CONSIDERE C NOEMAX: SI NOEMAX = 0 ALORS NOETRI N'EST PAS CONSIDERE C C C COORD,IDIMC : COORDONNEES DES NOEUDS C IDIMC : SI IDIMC = 0 ALORS COORD N'EST PAS CONSIDERE C C NUM : NUM(I) EST NUMERO DE L'ELEMENT QUI DOIT ETRE MIS EN I C ATTENTION !! NUM DOIT ETRE TRIE AVEC ENSTRI C NBNUM : NOMBRE DE NOEUDS A RENUMEROTER C C EN SORTIE: C ITRNOE : MIS A JOUR C NOETRI : MIS A JOUR C COORD : MIS A JOUR C C CONDITION D'APPLICATION : TOUT MAILLAGE C COMPLEXITE : O(NBNUM) + O(NBE) C PRINCIPE : LES PERMUTATIONS FONCTIONNENT SI NUM(I)>I C C.A.D. L'ANCIENNE POSITION > A LA NOUVELLE C ON EST DANS CE CAS SI NUM EST TRIE PAR ORDRE CROISS. C ***************************************************************** INTEGER ITRNOE(*),NBNMAX,NOETRI(*),NOEMAX,NBE REAL COORD(*) INTEGER IDIMC INTEGER NUM(*),NBNUM,IERR C INTEGER I,J,ITAMPO,NUMOLD REAL RTAMPO C DO 20 I=1,NBE C ----------------------------------- C --- MISE A JOUR DES NOEUDS DES ELEMENTS --- C ----------------------------------- DO 10 J=1,NBNMAX NUMOLD = ITRNOE((I-1)*NBNMAX + J) IF((NUMOLD.GT.0).AND.(NUMOLD.LE.NBNUM))THEN ITRNOE((I-1)*NBNMAX + J) = NUM(NUMOLD) ENDIF 10 CONTINUE 20 CONTINUE C ---------------------- C --- MISE A JOUR DES NOEUDS --- C ---------------------- DO 40 I=1,NBNUM IF( NOEMAX.NE.0)THEN ITAMPO = NOETRI(I) NOETRI(I) = NOETRI(NUM(I)) NOETRI(NUM(I)) = ITAMPO ENDIF DO 30 J=1,IDIMC RTAMPO = COORD((I-1)*IDIMC+J) COORD((I-1)*IDIMC+J) = COORD((NUM(I)-1)*IDIMC+J) COORD((NUM(I)-1)*IDIMC+J) = RTAMPO 30 CONTINUE 40 CONTINUE C IERR = 0 C 9999 END C SUBROUTINE NUNISO(NOETRI,NBN,NUM,NBISOL,IERR) C ***************************************************************** C OBJET NUNISO : PROPOSE UNE RENUMEROTATION POUR METTRE EN FIN LES C OBJET NOEUDS ISOLES. C C EN ENTREE: C NOETRI: TABLEAU DES ELEMENTS INCIDENTS AUX NOEUDS C NBN : NOMBRE DE NOEUDS C C EN SORTIE: C NBISOL : NOMBRE DE NOEUDS ISOLES C NUM : NOUVELLE NUMEROTATION C NUM(I) = NOUVEAU NUMERO DU NOEUD I C NUM EST UN TABLEAU DE TAILLE NBN C C CONDITION D'APPLICATION : TOUT MAILLAGE C ***************************************************************** INTEGER NOETRI(*),NBN INTEGER NUM(*),NBISOL,IERR C INTEGER I C NBISOL = 0 I = 1 10 IF(I.GT.(NBN-NBISOL))GOTO 9999 C --- LE NOEUD EST ISOLE --- IF( NOETRI(I).EQ.0 )THEN C C --- RECHERCHE D'UN NOEUD (A LA FIN) POUR PERMUTER --- 20 IF( NOETRI(NBN-NBISOL).EQ. 0 )THEN NUM(NBN-NBISOL) = NBN-NBISOL NBISOL = NBISOL + 1 C --- TOUS LES NOEUDS SONT ISOLES --- IF( NBISOL.EQ.NBN )GOTO 9999 C --- ON A TROUVE TOUS LES NOEUDS ISOLES --- IF( I.GT.(NBN-NBISOL))GOTO 9999 GOTO 20 ENDIF C C --- ON A LE NOEUD POUR PERMUTER --- NUM(NBN-NBISOL) = I NUM(I) = NBN-NBISOL NBISOL = NBISOL + 1 ELSE NUM(I) = I ENDIF I = I + 1 GOTO 10 C 9999 END C C SUBROUTINE NUENUL(ITRNOE,NBNMAX,NBE,NUM,NBENUL,IERR) C ***************************************************************** C OBJET NUENUL : PROPOSE UNE RENUMEROTATION POUR METTRE EN FIN LES C OBJET ELEMENTS NULS. C C EN ENTREE: C ITRNOE: LES NOEUDS DES ELEMENTS DU MAILLAGE C NBNMAX: NOMBRE MAXIMUM DE NOEUDS PAR ELEMENT C NBE : NOMBRE D'ELEMENTS C C EN SORTIE: C NBENUL : NOMBRE D'ELEMENTS NULS C NUM : NOUVELLE NUMEROTATION C NUM(I) = NOUVEAU NUMERO DE L'ELEMENT I C NUM EST UN TABLEAU DE TAILLE NBE C C C CONDITION D'APPLICATION : TOUT MAILLAGE C REMARQUE : IDEM NUNISO => UTILITAIRE SUR LES TABLEAUX ? C ***************************************************************** INTEGER ITRNOE(*),NBNMAX,NBE INTEGER NUM(*),NBENUL,IERR C INTEGER I C NBENUL = 0 I = 1 10 IF(I.GT.(NBE-NBENUL))GOTO 9999 C --- LE NOEUD EST ISOLE --- IF( ITRNOE((I-1)*NBNMAX+1).EQ.0 )THEN C C --- RECHERCHE D'UN NOEUD (A LA FIN) POUR PERMUTER --- 20 IF( ITRNOE((NBE-NBENUL-1)*NBNMAX+1).EQ. 0 )THEN NUM(NBE-NBENUL) = NBE-NBENUL NBENUL = NBENUL + 1 C --- TOUS LES NOEUDS SONT ISOLES --- IF( NBENUL.EQ.NBE )GOTO 9999 C --- ON A TROUVE TOUS LES NOEUDS ISOLES --- IF( I.GT.(NBE-NBENUL))GOTO 9999 GOTO 20 ENDIF C C --- ON A LE NOEUD POUR PERMUTER --- NUM(NBE-NBENUL) = I NUM(I) = NBE-NBENUL NBENUL = NBENUL + 1 ELSE NUM(I) = I ENDIF I = I + 1 GOTO 10 C 9999 END C C SUBROUTINE NUGCNU(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX, > NOETRI,NOEMAX,NBE,COORD,IDIMC,NBP, > ITVL,NITMAX,IERR) C ***************************************************************** C OBJET NUGCNU : GARBAGE COLLECTOR ELEMENTS ET POINTS C OBJET SUPPRIME LES ELEMENTS NULS ET LES POINTS ISOLES C OBJET LES POINTS ET LES ELEMENTS SONT RENUMEROTES !!! C C EN ENTREE: C ITRNOE,NBNMAX,ITRITRI,NBCMAX,NOETRI,NOEMAX,NBE : LE MAILLAGE C NBNMAX: SI NBNMAX = 0 ALORS ITRNOE N'EST PAS CONSIDERE C NOEMAX: SI NOEMAX = 0 ALORS NOETRI N'EST PAS CONSIDERE C COORD,NBP : COORDONNEES ET NOMBRE DE NOEUDS C IDIMC : DIMENSION DE L'ESPACE, SI IDIMC = 0 ALORS ON NE COMPRIME C PAS LES NOEUDS. C C ITVL(NITMAX) : TABLEAU DE TRAVAIL (ENTIERS), SA TAILLE EST DE C 2*NBP POUR LA RENUMEROTATION DES NOEUDS C + 2*NBE POUR LA RENUMEROTATION DES ELEMENTS C + NBP SI NOETRI N4EST PAS DONNE (NOEMAX=0) C C EN SORTIE: C ITRNOE,NBE,ITRTRI,NOETRI,COORD,NBN : MIS A JOUR C C CONDITION D'APPLICATION : TOUT MAILLAGE C ***************************************************************** INTEGER IDE,ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX INTEGER NOETRI(*),NOEMAX,NBE REAL COORD(*) INTEGER IDIMC,NBP,ITVL(*),NITMAX,IERR C INTEGER I,J,NUM,ITRAMA,NUM1,NBISOL,NBENUL INTEGER NOETR2 C NUM = 1 NBISOL = 0 NBENUL = 0 IF(IDIMC.EQ.0)GOTO 40 C ============================ C --- 1. COMPRESSION DES NOEUDS --- C ============================ IF( NOEMAX.EQ. 0 )THEN NOETR2 = 0 NUM = NBP + NOETR2 ENDIF ITRAMA = NUM + NBP IF( NITMAX .LT. ITRAMA+NBP )THEN IERR = -2 CALL DSERRE(1,IERR,'NUCGNU',' POUR COMPRIMER LES NOEUDS') CALL ESEINT(1,'PLACE NECESSAIRE : ',ITRAMA+NBP,1) CALL ESEINT(1,'PLACE DISPONIBLE : ',NITMAX,1) GOTO 9999 ENDIF C C ---- RECHERCHE DES NOEUDS CONNECTES ---- C -------------------------------- IF( NOEMAX.EQ. 0 )THEN DO 105 I=1,NBP ITVL(NOETR2+I) = 0 105 CONTINUE DO 120 I=1,NBE DO 110 J=1,NBNMAX NUM1 = ITRNOE((I-1)*NBNMAX+J) IF( NUM1.NE.0 )ITVL(NOETR2+NUM1) = I 110 CONTINUE 120 CONTINUE C CALL NUNISO(ITVL(NOETR2+1),NBP,ITVL(NUM+1),NBISOL,IERR) ELSE C CALL NUNISO(NOETRI,NBP,ITVL(NUM+1),NBISOL,IERR) ENDIF C IF( IERR.NE. 0 )THEN CALL DSERRE(1,IERR,'NUCGNU',' APPEL NUNISO ') GOTO 9999 ENDIF C C ---- SUPPRESSION DES NOEUDS PAS CONNECTES ---- C -------------------------------------- CALL NUNONU(ITRNOE,NBNMAX,NOETRI,NOEMAX,NBE, > COORD,IDIMC, > ITVL(NUM+1),NBP,ITVL(ITRAMA+1),IERR) IF( IERR.NE. 0 )THEN CALL DSERRE(1,IERR,'NUCGNU',' APPEL NUNONU ') GOTO 9999 ENDIF NBP = NBP - NBISOL C C ============================== C --- 2. COMPRESSION DES ELEMENTS --- C ============================== C 40 IF( IDE.EQ. 0 )GOTO 9999 CALL NUENUL(ITRNOE,NBNMAX,NBE,ITVL(NUM+1),NBENUL,IERR) IF( IERR.NE. 0 )THEN CALL DSERRE(1,IERR,'NUCGNU',' APPEL NUENUL ') GOTO 9999 ENDIF C ITRAMA = NUM + NBE CALL NURENU(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI, > NOEMAX,NBE,ITVL(NUM+1),ITVL(ITRAMA+1),IERR) C IF( IERR.NE. 0 )THEN CALL DSERRE(1,IERR,'NUCGNU',' APPEL NURENU ') GOTO 9999 ENDIF C NBE = NBE - NBENUL C C 9999 END C C ***************************************************************** C MODULE : ST (STRUCTURE DES DONNEES) C FICHIER : ST_0DSTRUCT.F C OBJET : AJOUT DE POINTS DANS UN MAILLAGE C FONCT. : C S0AJNO : AJOUTE UN POINT ISOLE OU LIBRE C S0DTNO : SUPPRIME LE POINT ISOLE OU LIBRE C C AUTEUR : O. STAB C DATE : 03.95 C TESTS : A FAIRE C MODIFICATIONS : C AUTEUR, DATE, OBJET : C C C ***************************************************************** C C SUBROUTINE S0AJNO(XYZ,COORD,IDIMC,NBN,NBNMAX, > NOETRI,NOEMAX,NNEW,IERR) C ***************************************************************** C OBJET : AJOUTE UN POINT ISOLE OU LIBRE C EN ENTREE : C XYZ : TABLEAU DES COORDONNEES DU POINT C COORD : TABLEAU DES COORDONNEES DE TOUS LES POINTS C IDIMC : DIMENSION DE L'ESPACE C NBN : NOMBRE DE NOEUDS DEJA EXISTANT C NBNMAX: NOMBRE MAXIMUM DE NOEUD DANS COORD C NOEMAX : SI = 0 NOETRI N'EST PAS MIS A JOUR C SINON NOEMAX = TAILLE DE NOETRI C EN SORTIE : C COORD, NOETRI ET NBN MODIFIES C NNEW : NUMERO DU NOEUD AJOUTE C IERR : CODE D'ERREUR 0 SI OK, -2 SI COORD EST TROP PETIT C ***************************************************************** REAL XYZ(*),COORD(*) INTEGER IDIMC,NBN,NBNMAX,IERR INTEGER NOETRI(*),NOEMAX,NNEW C INTEGER J C IF( NBN.GE.NBNMAX )THEN IERR = -2 CALL DSERRE(1,IERR,'ST','DANS S0AJNO : TROP DE POINTS') GOTO 999 ENDIF NBN = NBN + 1 DO 10 J=1,IDIMC COORD((NBN-1)*IDIMC+J) = XYZ(J) 10 CONTINUE NNEW = NBN IF( NOEMAX.GT. 0 )THEN IF( NOEMAX.LT.NNEW )THEN IERR =-2 CALL DSERRE(1,IERR,'ST','DANS S0AJNO : NOETRI TROP PETIT') GOTO 999 ENDIF NOETRI(NNEW) = 0 ENDIF IERR = 0 999 END C SUBROUTINE S0DTNO(IPADET,COORD,IDIMC,NBN,NBNMAX, > NOETRI,NOEMAX,IERR) C ***************************************************************** C OBJET : SUPPRIME LE POINT ISOLE OU LIBRE C EN ENTREE : C IPADET : LE POINT A SUPPRIMER C COORD : TABLEAU DES COORDONNEES DE TOUS LES POINTS C IDIMC : DIMENSION DE L'ESPACE C NBN : NOMBRE DE NOEUDS DEJA EXISTANT C NBNMAX: NOMBRE MAXIMUM DE NOEUD DANS COORD (POURRA SERVIR) C NOEMAX : SI = 0 NOETRI N'EST PAS MIS A JOUR C SINON NOEMAX = TAILLE DE NOETRI C EN SORTIE : C COORD, NOETRI ET NBN MODIFIES C IERR : CODE D'ERREUR 0 SI OK, -1 SI C'EST IMPOSSIBLE C ***************************************************************** REAL COORD(*) INTEGER IPADET,IDIMC,NBN,NBNMAX,IERR INTEGER NOETRI(*),NOEMAX C INTEGER J C --- ON NE PEUT SUPPRIMER QUE LE DERNIER POINT C IL DOIT ETRE ISOLE --- IF((IPADET.NE.NBN ).OR. > ((NOEMAX.NE.0).AND.(NOETRI(IPADET).NE.0)))THEN IERR = -1 CALL DSERRE(1,IERR,'ST', > 'DANS S0DTNO : POINT ENCORE CONNECTE') GOTO 999 ENDIF C DO 10 J=1,IDIMC COORD((NBN-1)*IDIMC+J) = 0.0 10 CONTINUE NBN = NBN - 1 IERR = 0 999 END C C ***************************************************************** C MODULE : ST (STRUCTURE DES DONNEES) C FICHIER : ST_1DSTRUCT.F C OBJET : CONSTRUCTION D'UN MAILLAGE LINEIQUE C FONCT. : C S1AJNO : DECOUPE UNE ARETE PAR UN SOMMET C S1CRAR : AJOUTE UNE ARETE ENTRE 2 SOMMETS EXISTANTS C S1LNFM : RENVOI 1 SI LE CONTOUR ACCESSIBLE EST FERME C 0 SINON C C AUTEUR : O. STAB C DATE : 03.95 C TESTS : A FAIRE C MODIFICATIONS : C AUTEUR, DATE, OBJET : O.STAB, 05.98, S1AJNO (CAS NBCMAX = 0) C C C ***************************************************************** C FUNCTION SFAC1D( IT1, IT2, N1, N2, IDE, I1, I2 ) C ***************************************************************** C OBJET SFAC1D : RECHERCHE LA FACE COMMUME A 2 ELEMENTS C ***************************************************************** INTEGER SFAC1D INTEGER IT1(N1), IT2(N2), N1,N2, IDE, I1, I2 C INTEGER I,J C ------------------------ C CAS DES ARETES : ON REALISE 4 COMPARAISONS (N1=N2=2) C ------------------------ DO 30 I=1,N1 DO 40 J=1,N2 IF (IT1(I) .EQ. IT2(J)) THEN I1 = I I2 = J IF( I.EQ.J )THEN SFAC1D = -1 ELSE SFAC1D = 1 ENDIF GOTO 9999 ENDIF 40 CONTINUE 30 CONTINUE 9999 END C SUBROUTINE S1INVE(N, IDE, ITRNOE, ITRTRI ) C ************************************************************ C OBJET S1INVE : INVERSE L'ORIENTATION D'UN ELEMENT A N NOEUDS C ************************************************************ INTEGER N, IDE, ITRNOE(N), ITRTRI(N) C INTEGER ITRNO1, ITRTR1 C 10 ITRNO1 = ITRNOE(1) ITRNOE(1) = ITRNOE(2) ITRNOE(2) = ITRNO1 ITRTR1 = ITRTRI(1) ITRTRI(1) = ITRTRI(2) ITRTRI(2) = ITRTR1 9999 END C FUNCTION S1NBCO(N,IDE) C **************************************************************** C OBJET S1NBCO : NOMBRE DE FACES D'UN ELEMENT DE N NOEUDS C ************************************************************ INTEGER S1NBCO INTEGER N,IDE C S1NBCO = N 9999 END C FUNCTION S1SOFA(IDE,I,N,IFAC) C ************************************************************ C OBJET S1SOFA : INDICES DES FACES INCIDENTES AU SOMMET I C ************************************************************ INTEGER S1SOFA INTEGER IDE,I,N,IFAC(*) C IFAC(1) = I S1SOFA = 1 9999 END C FUNCTION S1OPFA(IDE,N,IFE) C ************************************************************ C OBJET S1OPFA : INDICE DE L'ENTITE OPPOSEE A FACE IFE C EN SORTIE: C POUR LES TRIANGLES : LE SOMMET OPPOSE A L'ARETE C POUR LES QUADRANGLES : L'ARETE OPPOSEE A L'ARETE C ************************************************************ INTEGER S1OPFA INTEGER IDE,N,IFE C S1OPFA = MOD(IFE,N)+1 9999 END C FUNCTION S1FASO(IDE,N,I,ISOM) C ************************************************************ C OBJET S1FASO : INDICES DES SOMMETS DE LA FACE I (SENS DIRECT) C ************************************************************ INTEGER S1FASO INTEGER IDE,N,I,ISOM(*) C ISOM(1) = MOD(I+1-2,N)+1 S1FASO = 1 9999 END C C SUBROUTINE S1AJNO(IE,IS,NBE,ITRNOE,NBNMAX,ITRTRI,NBCMAX, > NOETRI,NOEMAX,IENEW,IERR) C ***************************************************************** C OBJET : DECOUPE UNE ARETE PAR UN SOMMET C |IA|-- IE -->|IB| C |IA|-- IE -->|IS|-- IENEW -->|IB| C C EN ENTREE: C IE : NUMERO DE L'ARETE A DECOUPER C IS : NUMERO DU SOMMET C NBE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,NOEMAX : LE MAILLAGE C NBCMAX : SI <= 0 ITRTRI N'EST PAS MIS A JOUR C NOEMAX : SI <= 0 NOETRI N'EST PAS MIS A JOUR C C EN SORTIE : C ITRNOE,NBE : LE MAILLAGE MODIFIE C ITRTRI : SI NBCMAX > 0 C NOETRI : SI NOEMAX > 0 C IENEW : LE NUMERO DE L'ARETE CREE C IERR : 0 SI OK C -1 SI LES DONNEES SONT ERRONEES C -2 SI NOETRI EST TROP PETIT C C REMARQUE : C'EST LE SEMV (SPLIT EDGE MAKE VERTEX) C ***************************************************************** INTEGER IE,IS,NBE INTEGER ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX INTEGER NOETRI(*), NOEMAX,IENEW,IERR C INTEGER ISEXTR, IESUIV C IENEW = 0 IF((IE.LE.0).OR.(IS.LE.0))THEN IERR = -1 CALL DSERRE(1,IERR,'ST','DANS S1AJNO : NUMERO INCORRECT') GOTO 9999 ENDIF ISEXTR = ITRNOE((IE-1)*NBNMAX+2) C IESUIV = ITRTRI((IE-1)*NBCMAX+2) IF(ISEXTR.LE.0)THEN IERR = -1 CALL DSERRE(1,IERR,'ST', > 'DANS S1AJNO : PAS D ARETE A DECOUPER') GOTO 9999 ENDIF C C --- CREATION DU NOUVEL ELEMENT ---------------- C IENEW = NBE + 1 ITRNOE((IENEW-1)*NBNMAX+1) = IS ITRNOE((IENEW-1)*NBNMAX+2) = ISEXTR C ITRTRI((IENEW-1)*NBCMAX+1) = IE C ITRTRI((IENEW-1)*NBCMAX+2) = IESUIV IF( NOEMAX.GT.0 )THEN IF( NOEMAX.LT.IS)THEN CALL DSERRE(1,IERR,'ST','DANS S1AJNO : NOEMAX TROP PETIT') IERR = -2 GOTO 9999 ENDIF NOETRI(IS) = IENEW NOETRI(ISEXTR) = IENEW ENDIF C C --- MISE A JOUR DE IE ET DE IESUIV ------------ C ITRNOE((IE-1)*NBNMAX+2) = IS C ITRTRI((IE-1)*NBCMAX+2) = IENEW C IF( IESUIV .GT. 0 )ITRTRI((IESUIV-1)*NBCMAX+1) = IENEW C NBE = NBE+1 C C --- MISE A JOUR DE ITRTRI ------------ C IENEW EST CREE ENTRE IE ET IESUIV : IE, IENEW,IESUIV IF( NBCMAX.GT.0 )THEN IESUIV = ITRTRI((IE-1)*NBCMAX+2) ITRTRI((IENEW-1)*NBCMAX+1) = IE ITRTRI((IENEW-1)*NBCMAX+2) = IESUIV ITRTRI((IE-1)*NBCMAX+2) = IENEW IF( IESUIV .GT. 0 )ITRTRI((IESUIV-1)*NBCMAX+1) = IENEW IF( IESUIV .LT. 0 )ITRTRI((-IESUIV-1)*NBCMAX+1) = -IENEW ENDIF NBE = NBE + 1 C 9999 END C C SUBROUTINE S1CRAR(ISO,ISE,NBE,ITRNOE,NBNMAX,ITRTRI,NBCMAX, > NOETRI,NOEMAX,IENEW,IERR) C ***************************************************************** C OBJET : AJOUTE UNE ARETE ENTRE 2 SOMMETS EXISTANTS C |ISO| |ISE| C |ISO|-- IENEW -->|ISE| C EN ENTREE: C ISO : NUMERO DU SOMMET ORIGINE C ISE : NUMERO DU SOMMET EXTREMITE C NBE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,NOEMAX :LE MAILLAGE C EN SORTIE : LE MAILLAGE MODIFIE C IENEW : LE NUMERO DE L'ARETE CREE C IERR : 0 SI OK C -1 SI LES DONNEES SONT ERRONEES C -2 SI NOETRI EST TROP PETIT C -3 SI HORS DES CONDITIONS D'APPLICATION C CONDITION D'APPLICATION : C'EST LE MEV (MAKE EDGE AND VERTEX) C ISO NE DOIT AVOIR AUCUNE ARETE QUI EN PART C ISE NE DOIT AVOIR AUCUNE ARETE QUI Y ARRIVE C ***************************************************************** INTEGER ISO,ISE,NBE INTEGER ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX INTEGER NOETRI(*), NOEMAX,IENEW,IERR C INTEGER IEO,IES C IERR = -1 IENEW = 0 IF((ISO.LE.0).OR.(ISE.LE.0))GOTO 999 C C ---- ON VERIFIE LE SOMMET ORIGINE ---------------- C IF((ISO.GT.NOEMAX).OR.(ISE.GT.NOEMAX ))GOTO 999 IEO = NOETRI(ISO) IF( ( IEO.NE.0 ).AND. > ( (ITRTRI((IEO-1)*NBCMAX+2).NE.0).OR. > (ITRNOE((IEO-1)*NBNMAX+2).NE.ISO) ) )THEN IERR = -3 GOTO 999 ENDIF C C ---- ON VERIFIE LE SOMMET EXTREMITE -------------- C IES = NOETRI(ISE) IF( ( IES.NE.0 ).AND. > ( (ITRTRI((IES-1)*NBCMAX+1).NE.0).OR. > (ITRNOE((IES-1)*NBNMAX+1).NE.ISE) ) )THEN IERR = -3 GOTO 999 ENDIF C C --- CREATION DU NOUVEL ELEMENT ---------------- C IENEW = NBE ITRNOE((IENEW-1)*NBNMAX+1) = ISO ITRNOE((IENEW-1)*NBNMAX+2) = ISE ITRTRI((IENEW-1)*NBCMAX+1) = IEO ITRTRI((IENEW-1)*NBCMAX+2) = IES C C --- MISE A JOUR DE IE ET DE IESUIV ------------ C IF( IES .NE. 0 )ITRTRI((IES-1)*NBCMAX+1) = IENEW IF( IEO .NE. 0 )ITRTRI((IEO-1)*NBCMAX+2) = IENEW C NBE = NBE+1 IERR = 0 C 999 END C FUNCTION S1LNFM(IT,ITRTRI,NBCMAX,ITD,ITF,NBE) C ***************************************************************** C OBJET : RENVOI 1 SI LE CONTOUR ACCESSIBLE DE IT EST FERME C 0 SINON C C EN ENTREE : C IT : UN ELEMENT DE LA CHAINE C ITRTRI: MAILLAGE LINEIQUE C NBCMAX : NOMBRE DE COTE DES ELEMENTS C EN SORTIE : C NBE : LE NOMBRE D'ARETES C ITD : ARETE DE DEBUT C ITF : ARETE DE FIN C C ***************************************************************** INTEGER S1LNFM INTEGER IT,ITRTRI(*),NBCMAX INTEGER ITD,ITF,NBE C INTEGER ISENS,ITI,ITS C IF(IT.LE.0)THEN S1LNFM = -1 GOTO 999 ENDIF ITD = 0 ITF = 0 ITI = IT ISENS = 0 NBE = 0 C 10 ITS = ITRTRI((ITI-1)*NBCMAX+1+ISENS) IF(ITS.EQ.0)THEN IF(ISENS.EQ.0)THEN C --- ON REPART DANS L'AUTRE SENS --- ISENS = 1 ITD = ITI ITI = IT NBE = NBE + 1 GOTO 10 ELSE ITF = ITI GOTO 20 ENDIF ELSE ITI = ITS NBE = NBE+1 ENDIF IF(ITI.NE.IT)GOTO 10 C 20 IF(ITD.EQ.0)THEN IF(ITF.NE.0)THEN S1LNFM = -1 ELSE S1LNFM = 1 ITD = IT ITF = ITRTRI((ITD-1)*NBCMAX+1) ENDIF ELSE IF(ITF.EQ.0)THEN S1LNFM = -1 ELSE S1LNFM = 0 ENDIF ENDIF C 999 END C C ***************************************************************** C MODULE : ST (STRUCTURE DES DONNEES) C FICHIER : ST_2DSTRUCT.F C OBJET : CONSULTATION, CONSTRUCTION ET MODIFICATION DE LA C STRUCTURE DE DONNE DU MAILLAGE 2D C FONCT. : C S2NBCO : CALCUL LE NOMBRE DE COTE REEL D'UN ELEMENT C S2GLUE : COLLAGE D'UN ELEMENT C S2GLAR : COLLE LA FRONTIERE D'UN MAILLAGE SUR LA FRONTIERE C D'UN DEUXIEME C OBJET S2SOTR : RENVOI DANS L'ORDRE LES SOMMETS OU ELEMENTS CONNECTES A ISOMM C C AUTEUR : O. STAB C DATE : 03.95 C TESTS : A FAIRE C MODIFICATIONS : C AUTEUR, DATE, OBJET : STAB, 02.03, AJOUT S2SOTR C C ***************************************************************** C FUNCTION SFAC2D( IT1, IT2, N1, N2, IDE, I1, I2 ) C ***************************************************************** C OBJET SFAC2D : RECHERCHE LA FACE COMMUME A 2 ELEMENTS C ***************************************************************** INTEGER SFAC2D INTEGER IT1(N1), IT2(N2), N1,N2, IDE, I1, I2 C INTEGER I,J C ----------------------- C CAS DES TRIANGLES OU DES QUADRANGLES C ON REALISE N1*N2*2 COMPARAISONS (X,Y) AVEC (A,B) ET (B,A) C ------------------------ DO 10 I=1,N1 DO 20 J=1,N2 IF ( (IT1(I) .EQ. IT2(J)) .AND. > (IT1(MOD(I,N1)+1) .EQ. IT2(MOD(J,N2)+1)) ) THEN I1 = I I2 = J SFAC2D = -1 GOTO 9999 ENDIF IF( (IT1(I) .EQ. IT2(MOD(J,N2)+1)) .AND. > (IT1(MOD(I,N1)+1) .EQ. IT2(J)) ) THEN I1 = I I2 = J SFAC2D = 1 GOTO 9999 ENDIF 20 CONTINUE 10 CONTINUE 9999 END C SUBROUTINE S2INVE(N, IDE, ITRNOE, ITRTRI ) C ************************************************************ C OBJET S2INVE : INVERSE L'ORIENTATION D'UN ELEMENT A N NOEUDS C CONDITION D'APPLICATION : TRIANGLE, QUADRANGLE C ************************************************************ INTEGER N, IDE, ITRNOE(N), ITRTRI(N) C INTEGER I, ITRNO1, ITRTR1 C 20 ITRNO1 = ITRNOE(N) ITRNOE(N) = ITRNOE(2) ITRNOE(2) = ITRNO1 DO 25 I=1,(N/2) ITRTR1 = ITRTRI(I) ITRTRI(I) = ITRTRI(N-I+1) ITRTRI(N-I+1) = ITRTR1 25 CONTINUE 9999 END C C C FUNCTION S2NBCO(N,IDE) C **************************************************************** C OBJET S2NBCO : NOMBRE DE FACES D'UN ELEMENT DE N NOEUDS C ************************************************************ INTEGER S2NBCO INTEGER N,IDE C S2NBCO = N 9999 END C FUNCTION S2SOFA(IDE,I,N,IFAC) C ************************************************************ C OBJET S2SOFA : INDICES DES FACES INCIDENTES AU SOMMET I C ************************************************************ INTEGER S2SOFA INTEGER IDE,I,N,IFAC(*) C IF( I.EQ.1 )THEN IFAC(1) = N ELSE IFAC(1) = I-1 ENDIF IFAC(2) = I S2SOFA = 2 9999 END C FUNCTION S2OPFA(IDE,N,IFE) C ************************************************************ C OBJET S2OPFA : INDICE DE L'ENTITE OPPOSEE A FACE IFE C EN SORTIE: C POUR LES TRIANGLES : LE SOMMET OPPOSE A L'ARETE C POUR LES QUADRANGLES : L'ARETE OPPOSEE A L'ARETE C ************************************************************ INTEGER S2OPFA INTEGER IDE,N,IFE C S2OPFA = MOD(IFE+1,N)+1 9999 END C FUNCTION S2FASO(IDE,N,I,ISOM) C ************************************************************ C OBJET S2FASO : INDICES DES SOMMETS DE LA FACE I (SENS DIRECT) C ************************************************************ INTEGER S2FASO INTEGER IDE,N,I,ISOM(*) C INTEGER K C DO 10 K=1,2 ISOM(K) = MOD(I+K-2,N)+1 10 CONTINUE S2FASO = 2 9999 END C C SUBROUTINE S2FASU(IDE,NBNE,ISOM,IFAC) C ************************************************************ C OBJET S2FASU : FACE SUIVANTE SUR SOMMET(S) C ************************************************************ INTEGER IDE,NBNE,ISOM(1) INTEGER IFAC C IFAC = MOD(ISOM(1)+(NBNE-2),NBNE)+1 C 9999 END C C C FUNCTION S2NBCO_OLD(IT,ITRNOE, NMAX) C **************************************************************** C OBJET : C CALCUL LE NOMBRE DE COTE REEL D'UN ELEMENT C NECESSAIRE QUAND ON A DES MAILLAGES MIXTES (TRIANGLE,TETRA) C EN ENTREE: C NMAX : (3,4) NOMBRE DE COTES MAXIMUM DES ELEMENTS DU C MAILLAGE C IT : INDICE DE L'ELEMENT C ITRNOE: LES NOEUDS DES ELEMENTS C EN SORTIE: C CONDITION D'APPLICATION : TRIANGLE, QUADRANGLE C ************************************************************ C INTEGER S2NBCO C INTEGER ITRNOE(*), IT, NMAX C C S2NBCO = 3 C --- CAS DU QUADRANGLE --- C IF((NMAX.EQ.4).AND.(ITRNOE((IT-1)*NMAX+4).NE.0))S2NBCO = 4 C END C SUBROUTINE S2GLUE(IT,IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX, > NOETRI,IERR) C ***************************************************************** C OBJET S2GLUE : COLLAGE D'UN ELEMENT C MISE A JOUR DU TABLEAUX ITRTRI POUR CONNECTER L'ELEMENT C AVEC LE RESTE C EN ENTREE : C IT :L'ELEMENT A COLLER C IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI : LE MAILLAGE C EN SORTIE : LE MAILLAGE MODIFIE C IERR : 0 SI OK, -1 SI DONNEES ERRONEES C CONDITIONS D'APPLICATION : C ***************************************************************** INTEGER IT,IDE,ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX INTEGER NOETRI(*),IERR C C PRINCIPE : C RECHERCHE DES FACES COMMUNES ENTRE IT ET NOETRI(ITRNOE(IT)) C INTEGER IATR(4),I,ITC,IF,NIT,NITC,IFIT,IFITC INTEGER SFAC2D, STRNBN, ISENS, NP EXTERNAL SFAC2D, STRNBN C NIT = STRNBN(IT,ITRNOE,NBNMAX) ISENS = 1 DO 10 I=1,NIT IF( ITRTRI((IT-1)*NBCMAX+I).EQ.0 )THEN IATR(I) = 1 ELSE IATR(I)= 0 ENDIF 10 CONTINUE DO 30 I=1,NIT IF( IATR(I) .EQ. 1 )THEN NP = ITRNOE((IT-1)*NBNMAX+I) CALL SESFR2(NP,ISENS,IDE,ITRNOE,NBNMAX,ITRTRI, > NBCMAX,NOETRI,ITC,IF) C --- DE LA PREMIERE ARETE DE FRONTIERE --- IF( ITRTRI((ITC-1)*NBCMAX+IF) .NE. 0 )THEN IERR = -1 GO TO 999 ENDIF 20 CALL SESFR1(ITC,IF,ITRTRI,NBCMAX,ITC,IF) IF( ITRTRI((ITC-1)*NBCMAX+IF) .NE. 0 )GO TO 20 NITC = STRNBN(ITC,ITRNOE,NBNMAX) C --- A LA DERNIERE ARETE DE FRONTIERE --- IF( SFAC2D(IT,ITC,NIT,NITC,IDE,IFIT,IFITC).EQ.1)THEN ITRTRI((IT-1)*NBCMAX + IFIT) = IFITC ITRTRI((ITC-1)*NBCMAX + IFITC) = IFIT ENDIF ITRTRI((IT-1)*NBCMAX + I) = 0 ENDIF 30 CONTINUE 999 END C C SUBROUTINE S2GLAR(IFR1,NBF1,IFR2,NBF2,ITRNOE,NBNMAX, > ITRTRI,NBCMAX,NBCCOL) C ***************************************************************** C OBJET S2GLAR : COLLE LA FRONTIERE D'UN MAILLAGE SUR UNE AUTRE C C EN ENTREE: C IFR1 : FRONTIERE A COLLER C NBFR1: NOMBRE D'ELEMENTS DE LA FRONTIERE C IFR2 : FRONTIERE SUR LAQUELLE ON COLLE C NBFR2: NOMBRE D'ELEMENTS DE LA FRONTIERE C --- LE MAILLAGE ------------------------ C ITRNOE,NBNMAX,ITRTRI,NBCMAX : LE MAILLAGE C C EN SORTIE: LE MAILLAGE MODIFIE (ITRTRI) C NBCCOL: LE NOMBRE D'ARETE DE IFR1 COLLEES A IFR2 C REMARQUES : C PAS DE VERIFICATION DE LA REGULARITE DE LA FRONTIERE C LES 2 MAILLAGES DOIVENT ETRE DANS LES MEMES TABLEAUX C ET ORIENTES DE LA MEME FACON. C COMPLEXITE : POUR CHAQUE ARETE DE IFR1 ON PARCOURS TOUTES LES C ARETES DE IFR2 C ON UTILISE PAS LA STRUCTURE (ITRITRI) POUR LE PARCOURS CAR C ELLE N'EST PAS FORCEMENT CORRECTE. C C ***************************************************************** INTEGER IFR1(*),NBF1,IFR2(*),NBF2 INTEGER ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX,NBCCOL C INTEGER I,J,IT1,IT2,IF1,IF2,IORIG,IEXTR,NBRN1 INTEGER ISENS INTEGER STRNBN EXTERNAL STRNBN C C --- MISE A JOUR DE ITRTRI ----------------- C NBCCOL = 0 DO 20 I=1,NBF1 NBRN1 = STRNBN(I,ITRNOE,NBNMAX) IT1 = IFR1((I-1)*2+1) IF1 = IFR1((I-1)*2+2) C --- POUR LES FRONTIERES INTERIEURES --- ISENS = 1 IF( IF1.LT. 0 )THEN ISENS = -1 IF1 = -IF1 ENDIF IEXTR = ITRNOE((IT1-1)*NBNMAX+MOD(IF1,NBRN1)+1) DO 10 J=1,NBF2 IT2 = IFR2((J-1)*2+1) IF2 = IFR2((J-1)*2+2) C --- POUR LES FRONTIERES INTERIEURES --- IF( IF2.LT. 0 )THEN ISENS = -1 IF2 = -IF2 ENDIF IORIG = ITRNOE((IT2-1)*NBNMAX+IF2) IF( IORIG .EQ. IEXTR )THEN ITRTRI((IT2-1)*NBCMAX+IF2) = ISENS * IT1 ITRTRI((IT1-1)*NBCMAX+IF1) = ISENS * IT2 NBCCOL = NBCCOL+1 GO TO 20 ENDIF 10 CONTINUE C --- ON EST SUR LA FRONTIERE --- ITRTRI((IT1-1)*NBCMAX+IF1) = 0 20 CONTINUE 999 END C SUBROUTINE S2SOTR(ISOMM,ITYPE, > IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI, > ISOMFR,NBTRSO,ITABSE,ITABMX,IERR) C ***************************************************************** C OBJET S2SOTR : RENVOI DANS L'ORDRE LES SOMMETS OU ELEMENTS CONNECTES A ISOMM C C EN ENTREE : C ISOMM : LE SOMMET SUR LEQUEL ON TOURNE C ITYPE : 0 on stocke les sommets (dans ITABSE) C 1 " " " les elements (dans ITABSE) C ITABSE : Tableau ou seront stockes objets connectes a ISOMM C ITABMX : Taille de ITABSE C EN SORTIE : C ISOMFR : 1 si le sommet appartient a la frontiere C 0 sinon C NBTRSO : nombre de triangles incidents a ISOMM C le nombre de sommets = NBTRSO + ISOMFR C ITABSE : Tableau des elements connectes a ISOMM (dans l'ordre) C ou C Tableau des sommets connectes a ISOMM (dans l'ordre) C si ISOMFR=0 ITABSE(i) est ferme C si ISOMFR=1 ITBASE(i) est ouvert C C REMARQUE : C ***************************************************************** INTEGER ISOMM,ITYPE INTEGER IDE,ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX,NOETRI(*) INTEGER ISOMFR,NBTRSO,ITABSE(*),ITABMX,IERR C EXTERNAL STRKSF INTEGER STRKSF INTEGER ITRDEB,IARDEB,IT,IAR,IT2,IAR2,I,ISENS INTEGER ISOMAR(2),NBSOAR,NBNE,ISO,IARS,ISOMEX C NBTRSO = 0 ISOMFR = 1 C NBNE = 3 C --- SENS EST INUTILISE !!!! ???? ISENS = 1 CALL SESFR2(ISOMM,ISENS,IDE,ITRNOE,NBNMAX,ITRTRI, > NBCMAX,NOETRI,ITRDEB,IARDEB) C --- le sommet n'appartient a aucun element ! --- IF((IARDEB.LE.0 ).OR.( ITRDEB.LE.0 ))GOTO 9999 IT = ITRDEB IAR = IARDEB C 10 CONTINUE NBTRSO = NBTRSO + 1 IARS = MOD(IAR,3)+1 IF( ITYPE.EQ.0 )THEN IF( NBTRSO.LT.ITABMX )THEN C -- on stocke l'origine de l'arete --- ITABSE(NBTRSO)= ITRNOE((IT-1)*NBNMAX+IAR) C -- on stocke l'extremitee de l'arete suivante --- ISOMEX = MOD(IARS,3)+1 ITABSE(NBTRSO+1)= ITRNOE((IT-1)*NBNMAX+ISOMEX) ENDIF ELSE IF( NBTRSO.LE.ITABMX )ITABSE(NBTRSO)= IT ENDIF C CALL SESFR1(IT,IARS,ITRTRI,NBCMAX,IT2,IAR2) IF( IT2.LE.0 )THEN C --- le sommet est sur la frontiere --- ISOMFR = 1 GOTO 20 ENDIF IF((IT2.EQ.ITRDEB).AND.(IAR2.EQ.IARDEB))THEN C --- le sommet est interieur --- ISOMFR = 0 GOTO 20 ENDIF IAR = IAR2 IT = IT2 GOTO 10 C --- on sort de la boucle 20 CONTINUE C WRITE(*,*) 'SOMMET ' , ISOMM C WRITE(*,*) 'NBTRSO = ',NBTRSO,' ISOMFR = ',ISOMFR C WRITE(*,*) (ITABSE(I),I=1,NBTRSO+ISOMFR) C WRITE(*,*) '------------------------------------' 9999 END C C ***************************************************************** C MODULE : ST (STRUCTURE DES DONNEES) C FICHIER : ST3D_STRUCT.F C OBJET : CONSULTATION, CONSTRUCTION ET MODIFICATION DE LA C STRUCTURE DE DONNE DU MAILLAGE 3D C FONCT. : C C SFAC3D : RECHERCHE LA FACE COMMUNE A 2 ELEMENTS 3D C C S3NBCO : CALCUL DU NOMBRE DE COTE D'UN ELEMENT C S3NBCF : CALCUL DU NOMBRE DE COTE DE LA FACE D'UN ELEMENT C C S3FDIA : FACE DIRECTE SUR UNE ARETE (INDICE RELATIF) C S3A2FA : ARETE COMMUNE A 2 FACES (INDICE RELATIF) C S3FASO : K SOMMETS DE LA FACE (INDICE RELATIF) C S3SOFA : K FACES AU SOMMET (INDICE RELATIF) C S3OPFA : ENTITE OPPOSEE A FACE (INDICE RELATIF) C C S3INVE : INVERSE L'ORIENTATION D'UN ELEMENT 3D C C AUTEUR : O. STAB C DATE : 03.95 C TESTS : C C MODIFICATIONS : C AUTEUR, DATE, OBJET : O.STAB, 26.06.96, AJOUT SFAC3D (A TERMINER) C C MODIFICATIONS : C AUTEUR, DATE, OBJET : C C C ***************************************************************** C SUBROUTINE SFRI3D(NN,NBNN, > IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX, > NOETRI,NBE,ITVL,NITMAX, > IT1,IT2,I1,I2,IERR) C ************************************************************* C OBJET SFRI3D : ELEMENTS SUR LA FACE NN (VOIR SFRIDE) C EN ATTENDANT.... C ************************************************************* INTEGER NN(*),NBNN,IDE,ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX INTEGER NOETRI(*),NBE,ITVL(*),NITMAX INTEGER IT1,IT2,I1,I2,IERR C IERR = -3 9999 END C FUNCTION SFAC3D( IT1, IT2, N1, N2, IDE, I1, I2 ) C ***************************************************************** C OBJET SFAC3D : RECHERCHE LA FACE COMMUME A 2 ELEMENTS C RENVOI LES INDICES I1 ET I2 CORRESPONDANTS AUX FRONTIERES C COMMUNES DES ELEMENTS IT1 ET IT2. C C EN ENTREE: C IT1,IT2: LES ELEMENTS A TESTER C N1 : (2..4) NOMBRE DE NOEUDS DE IT1 C N2 : (2..4) NOMBRE DE NOEUDS DE IT2 C C EN SORTIE: C I1,I2 : INDICES DES FRONTIERES COMMUNES C SFAC3D : 0 SI AUCUNE ARETE COMMUNE C -1 SI I1 ET I2 SONT PARCOURUS DANS LE MEME C SENS POUR IT1 ET IT2 C 1 SI " " " " DANS LE SENS INVERSE C C CONDITION D'APPLICATION : TETRA, HEXA... C REMARQUE : N'UTILISE PAS LA STRUCTURE DE DONNEES MAILLAGE C N'EXPLOITE AUCUNE HYPOTHESE SUR IT1 ET IT2 C ***************************************************************** INTEGER SFAC3D INTEGER IT1(N1), IT2(N2), N1,N2, IDE, I1, I2 C INTEGER IT12(16),ISOM(16) INTEGER NBNF1(6),NBNF2(6),ISOMT1(4,6),ISOMT2(4,6) INTEGER I,IFF,IFF1,IFF2,NBF1,NBF2,INO,ISENS,NBNC,INO2 INTEGER S3NBCO,S3FASO EXTERNAL S3NBCO,S3FASO C C WRITE(6,*) 'ON ENTRE DANS SFAC3D it1,it2 = ',IT1,IT2 C IDE = 3 C WRITE(*,*) 'ON COMPARE :' C WRITE(*,*) (IT1(I),I=1,N1), 'ET ' C WRITE(*,*) (IT2(I),I=1,N2) C C COMPARER LA SIGNATURE DES 4 NOEUDS POUR OPTIMISER C -------------------------------------------------- DO 50 I=1,N1 ISOM(I) = IT1(I) 50 CONTINUE DO 51 I=1,N2 ISOM(I+N1) = IT2(I) 51 CONTINUE CALL KNUTA(N1+N2,ISOM) NBNC = 0 DO 52 I=1,(N1+N2-1) IF(ISOM(I).EQ.ISOM(I+1))NBNC = NBNC+1 52 CONTINUE C WRITE(*,*) 'NOMBRE DE NOEUDS EN COMMUN :',NBNC C IF( NBNC.LT.3 )THEN SFAC3D = 0 GOTO 9999 ENDIF C IF(((N1.EQ.8).OR.(N2.EQ.8)).AND.(NBNC.EQ.3))THEN SFAC3D = 0 GOTO 9999 ENDIF C WRITE(6,*) 'IT1,IT2 = ',IT1,IT2 C C --- IL Y A AU MOINS 3 NOEUDS EN COMMUN --- C IL FAUT TROUVER LES FACES ET LEURS INDICES C C --- LES FACES DE IT1 --- C C WRITE(*,*) 'PREMIER ELEMENT' ISENS = 1 NBF1 = S3NBCO(N1,3) DO 61 IFF=1,NBF1 C NBNF1(IFF) = S3FASO(IFF,N1,ISENS,ISOMT1(1,IFF)) NBNF1(IFF) = S3FASO(3,N1,IFF,ISOMT1(1,IFF)) C WRITE(*,*) 'FACE :',IFF,' DE ',NBNF1(IFF),' SOMMETS =' C WRITE(*,*) (ISOMT1(INO,IFF),INO=1,3) C WRITE(*,*) 'ELEMENT =',(IT1(INO),INO=1,4) DO 60 INO=1,NBNF1(IFF) ISOMT1(INO,IFF)= IT1(ISOMT1(INO,IFF)) C WRITE(*,*) ISOMT1(INO,IFF) 60 CONTINUE C CALL KNUTA(NBNF1(IFF),ISOMT1(1,IFF)) 61 CONTINUE C C --- LES FACES DE IT2 --- C C WRITE(*,*) 'SECOND ELEMENT' NBF2 = S3NBCO(N2,3) DO 63 IFF=1,NBF2 C NBNF2(IFF) = S3FASO(IFF,N2,ISENS,ISOMT2(1,IFF)) NBNF2(IFF) = S3FASO(3,N2,IFF,ISOMT2(1,IFF)) C WRITE(*,*) 'FACE :',IFF,' DE ',NBNF2(IFF),' SOMMETS =' C WRITE(*,*) (ISOMT2(INO,IFF),INO=1,3) DO 62 INO=1,NBNF2(IFF) ISOMT2(INO,IFF)= IT2(ISOMT2(INO,IFF)) 62 CONTINUE C CALL KNUTA(NBNF2(IFF),ISOMT2(1,IFF)) 63 CONTINUE C C --- COMPARAISON --- C C WRITE(*,*) 'COMPARAISON' C WRITE(*,*) 'FACES = ',((ISOMT1(INO,IFF1),INO=1,3),'/',IFF1=1,4) C WRITE(*,*) 'FACES = ',((ISOMT2(INO,IFF1),INO=1,3),'/',IFF1=1,4) DO 80 IFF1=1,NBF1 DO 75 IFF2=1,NBF2 IF( NBNF1(IFF1).EQ.NBNF2(IFF2) )THEN INO = 1 INO2 = 1 C ---- ON CHERCHE LE DEBUT --------------------- 74 IF( ISOMT1(INO,IFF1).NE.ISOMT2(INO2,IFF2))THEN INO2 = INO2 + 1 IF( INO2.GT.NBNF2(IFF2) ) GOTO 75 GOTO 74 ENDIF C ---- ON RECHERCHE LE SENS -------------------- IF( ISOMT1(INO+1,IFF1).NE. > ISOMT2(MOD(INO2,NBNF2(IFF2))+1,IFF2))THEN ISENS = -1 ELSE ISENS = 1 ENDIF C C ---- ON COMPARE 2 LISTES CIRCULAIRES --------- C 77 INO = INO+1 IF(ISENS.EQ.1)THEN INO2 = MOD(INO2,NBNF2(IFF2)) + 1 ELSE INO2 = NBNF2(IFF2) - MOD(NBNF2(IFF2)+1-INO2,NBNF2(IFF2)) ENDIF IF( ISOMT1(INO,IFF1).NE.ISOMT2(INO2,IFF2))GOTO 75 C ---- IF( INO.EQ. NBNF1(IFF1) )THEN I1 = IFF1 I2 = IFF2 SFAC3D = -ISENS C WRITE(*,*) 'FACE COMMUNE :',I1,I2 GOTO 9999 ENDIF GOTO 77 ENDIF 75 CONTINUE 80 CONTINUE C SFAC3D = 0 C 9999 END C C SUBROUTINE S3INVE(N, IDE, ITRNOE, ITRTRI ) C ************************************************************ C OBJET S3INVE : INVERSE L'ORIENTATION D'UN ELEMENT A N NOEUDS C C EN ENTREE: C N : (2..4) NOMBRE DE NOEUDS DE L'ELEMENT C ITRNOE: LES NOEUDS DU TRIANGLES C ITRTRI: LES VOISINS DU TRIANGLES C EN SORTIE: C ITRTRI : MIS A JOUR C ITRNOE : MIS A JOUR C CONDITION D'APPLICATION : TETRAEDRE C C REMARQUE : PERMUTER LES NOEUDS (I,J) REVIENT A PERMUTER LES C FACE (I,J) ET A INVERSER LE SENS DE TOUTES LES C FACES C ************************************************************ INTEGER N,IDE,ITRNOE(N),ITRTRI(N) C INTEGER ITRNO1, ITRTR1 C IF( N.EQ.4 )THEN ITRNO1 = ITRNOE(3) ITRNOE(3) = ITRNOE(2) ITRNOE(2) = ITRNO1 ITRTR1 = ITRTRI(3) ITRTRI(3) = ITRTRI(2) ITRTRI(2) = ITRTR1 ENDIF END C C FUNCTION S3NBCO(N,IDE) C ************************************************************* C OBJET S3NBCO : NOMBRE DE FACES D'UN ELEMENT DE N NOEUDS C CONDITION D'APPLICATION : TETRA, PYRA, PRISME, HEXA C MODIF 21.01.99 : AJOUT DE L'ELEMENT VIDE C ************************************************************ INTEGER S3NBCO INTEGER N,IDE C INTEGER IERR C GOTO (5,1,1,1,100,100,100,1,200) (N+1) C ===================== C --- ELEMENT VIDE --- C ===================== 5 S3NBCO = 0 GOTO 9999 C ===================== C --- ELEMENT NON RECONNU --- C ===================== 1 S3NBCO = -1 IERR = -1 CALL DSERRE(1,IERR,'S3NBCO',' TYPE D ELEMENT INCONNU') GOTO 9999 C ==================================== C --- CAS DU TETRAEDRE, PYRAMIDE, PRISME --- C ==================================== 100 S3NBCO = N GOTO 9999 C ================== C --- CAS DE L'HEXAEDRE --- C ================== 200 S3NBCO = 6 GOTO 9999 C 9999 END C FUNCTION S3NBCF(NBC,NF) C ************************************************************ C OBJET : CALCUL DU NOMBRE DE COTE DE LA FACE D'UN ELEMENT C NECESSAIRE QUAND ON A DES ELEMENTS (PRISME,PYRA...) C EN ENTREE: C NBC : (4,5,6,8) NOMBRE DE COTES DE L'ELEMENTS C NF : NUMERO DE LA FACE C EN SORTIE: C CONDITION D'APPLICATION : TETRA C ************************************************************ INTEGER S3NBCF INTEGER NBC, NF C S3NBCF = 4 IF( NBC .EQ. 4 )GO TO 999 S3NBCF = -1 999 END C C SUBROUTINE S3FDIA(I,J,N,IFACE) REMPLACE PAR : SUBROUTINE S3FASU(IDE,N,ISOM,IFAC) C ************************************************************ C OBJET S3FASU : FACE DIRECTE SUR UNE ARETE (INDICE RELATIF) C EN ENTREE: C ISOM(1,2): LES INDICES DES SOMMETS DE L'ARETE C N : (4) NOMBRE DE COTES DE L'ELEMENT C TETRA(4),PYRAM(5),PRISME(6),HEXA(8) C EN SORTIE: C IFACE : INDICE DE LA FACE DIRECTE DANS LE TABLEAU TRITRI C CONDITION D'APPLICATION : TETRAEDRE SEULEMENT C C A TESTER C ************************************************************ INTEGER IDE, N, ISOM(2), IFAC C COMMON /STRTET/ ITA2F(4,4),IT2FA(4,4),IT3SF(3,4) INTEGER ITA2F, IT2FA, IT3SF C IF( N .EQ. 4 )THEN C --- CAS DU TETRAEDRE --- IFAC = IT2FA(ISOM(1),ISOM(2)) ENDIF 999 END C SUBROUTINE S3A2FA(I,J,N,N1,N2) C ************************************************************ C OBJET : ARETE COMMUNE A 2 FACES (INDICE RELATIF) C EN ENTREE: C I,J : LES INDICES DES FACES DE L'ELEMENT C N : (4) NOMBRE DE COTES DE L'ELEMENT C TETRA(4),PYRAM(5),PRISME(6),HEXA(8) C EN SORTIE: C N1,N2 : INDICE DES EXTREMITES DE L'ARETE (DIRECTE POUR I) C CONDITION D'APPLICATION : TETRAEDRE SEULEMENT C C A TESTER C ************************************************************ INTEGER I, J, N, N1, N2 C COMMON /STRTET/ ITA2F(4,4),IT2FA(4,4),IT3SF(3,4) INTEGER ITA2F, IT2FA, IT3SF C IF( N .EQ. 4 )THEN C --- CAS DU TETRAEDRE --- N1 = ITA2F(I,J) N2 = ITA2F(J,I) ENDIF 999 END C C FUNCTION S3FASO(I,N,ISENS,ISOM) A ETE MODIFIE LE 14.08.98 FUNCTION S3FASO(IDE,N,I,ISOM) C ************************************************************ C OBJET S3FASO : INDICES DES SOMMETS DE LA FACE I (SENS DIRECT) C CONDITION D'APPLICATION : TETRAEDRE ET HEXAEDRE SEULEMENT C ************************************************************ INTEGER S3FASO INTEGER IDE,I,N,ISOM(*) C COMMON /STRTET/ ITA2F(4,4),IT2FA(4,4),IT3SF(3,4) INTEGER ITA2F, IT2FA, IT3SF COMMON /STRHEX/ IQ4SF(4,6),IQ3FS(3,8) INTEGER IQ4SF,IQ3FS INTEGER ISENS,J,IERR C ISENS = 1 GOTO (1,1,1,100,1,1,1,200) N C ===================== C --- ELEMENT NON RECONNU --- C ===================== 1 S3FASO = 0 IERR = -1 CALL DSERRE(1,IERR,'S3FASO',' TYPE D ELEMENT INCONNU') GOTO 9999 C ================== C --- CAS DU TETRAEDRE --- C ================== 100 S3FASO = 3 IF( ISENS .EQ. 1 )THEN DO 110 J=1,S3FASO ISOM(J) = IT3SF(J,I) 110 CONTINUE ELSE DO 120 J=1,S3FASO ISOM(J) = IT3SF(S3FASO+1-J,I) 120 CONTINUE ENDIF GOTO 9999 C ================== C --- CAS DE L'HEXAEDRE --- C ================== 200 S3FASO = 4 IF( ISENS .EQ. 1 )THEN DO 210 J=1,S3FASO ISOM(J) = IQ4SF(J,I) 210 CONTINUE ELSE DO 220 J=1,S3FASO ISOM(J) = IQ4SF(S3FASO+1-J,I) 220 CONTINUE ENDIF GOTO 9999 C 9999 END C C FUNCTION S3SOFA(IDE,I,N,IFAC) C ************************************************************ C OBJET S3SOFA : INDICES DES FACES INCIDENTES AU SOMMET I C CONDITION D'APPLICATION : TETRAEDRE ET HEXAEDRE SEULEMENT C ************************************************************ INTEGER S3SOFA INTEGER IDE,I,N,IFAC(*) C COMMON /STRTET/ ITA2F(4,4),IT2FA(4,4),IT3SF(3,4) INTEGER ITA2F, IT2FA, IT3SF COMMON /STRHEX/ IQ4SF(4,6),IQ3FS(3,8) INTEGER IQ4SF,IQ3FS INTEGER J,IERR C C write(6,*) 'INDICE DU SOMMET = ',I C write(6,*) 'NOMBRE DE NOEUDS = ',N GOTO (1,1,1,100,1,1,1,200) N C ===================== C --- ELEMENT NON RECONNU --- C ===================== 1 S3SOFA = 0 IERR = -1 CALL DSERRE(1,IERR,'S3SOFA',' TYPE D ELEMENT INCONNU') GOTO 9999 C ================== C --- CAS DU TETRAEDRE --- C ================== C 100 S3SOFA = 3 DO 110 J=1,S3SOFA IFAC(J) = IT3SF(J,I) 110 CONTINUE GOTO 9999 C ================== C --- CAS DE L'HEXAEDRE --- C ================== 200 S3SOFA = 3 DO 210 J=1,S3SOFA IFAC(J) = IQ3FS(J,I) 210 CONTINUE GOTO 9999 C 9999 END C FUNCTION S3OPFA(IDE,N,IFE) C ************************************************************ C OBJET S3OPFA : INDICE DE L'ENTITE OPPOSEE A FACE IFE C EN SORTIE: C POUR LES TETRAEDRES : INDICE DU NOEUD OPPOSE C POUR L'HEXAEDRE : FACE OPPOSEE C POUR LE PRISME : ARETE OPPOSE POUR LES FACES QUAD C FACE OPPOSE POUR LES FACES TRI C POUR LA PYRAMIDE : C C CONDITION D'APPLICATION : TETRAEDRE C ************************************************************ INTEGER S3OPFA INTEGER IDE,N, IFE C IF( N .EQ. 4 )THEN C --- CAS DU TETRAEDRE --- S3OPFA = IFE C PRINT *,'A FAIRE' ELSE S3OPFA = 0 ENDIF 999 END C C C C C * BLOCK DATA STRU3D C C POUR LES TETRA : C ITA2F : ARETE PARTAGEE PAR 2 FACES C ITA2F(I,J),ITA2F(J,I) = L'ARETE COMMUNE C AU FACES I ET J ET DIRECTE POUR I C C IT2FA : LES 2 FACES INCIDENTES A UNE ARETE C IT2FA(I,J) = FACE DIRECTE POUR L'ARETE I,J C IT2FA(J,I) = FACE INDIRECTE C C IT3SF : LES 3 SOMMETS D'UNE FACE C * COMMON /STRTET/ ITA2F(4,4),IT2FA(4,4),IT3SF(4,3) * INTEGER ITA2F, IT2FA, IT3SF * DATA ITA2F / 0,4,2,3, 3,0,4,1, 4,1,0,2, 2,3,1,0 / * DATA IT2FA / 0,4,2,3, 3,0,4,1, 4,1,0,2, 2,3,1,0 / * DATA IT3SF / 4,3,2, 3,4,1, 4,2,1, 1,2,3 / * END C SUBROUTINE ST3INI C ********************************************************************** C OBJET : INITIALISE LES CONSTANTES STRUCTURALES DU COMMON STRTET C C REMARQUE : C L'INITIALISATION DES CONSTANTES EST REALISE PAR PROCEDURE C PLUTOT QUE PAR UN BLOCK DATA POUR DES RAISONS DE PORTABILITE. C ST3INI DOIT ETRE APPELEE AU DEBUT DE CHAQUE PROGRAMME C ********************************************************************** C C POUR LES TETRA : C ITA2F : ARETE PARTAGEE PAR 2 FACES C ITA2F(I,J),ITA2F(J,I) = L'ARETE COMMUNE C AU FACES I ET J ET DIRECTE POUR I C C IT2FA : LES 2 FACES INCIDENTES A UNE ARETE C IT2FA(I,J) = FACE DIRECTE POUR L'ARETE I,J C IT2FA(J,I) = FACE INDIRECTE C C IT3SF : LES 3 SOMMETS D'UNE FACE C COMMON /STRTET/ ITA2F(4,4),IT2FA(4,4),IT3SF(3,4) INTEGER ITA2F, IT2FA, IT3SF COMMON /STRHEX/ IQ4SF(4,6),IQ3FS(3,8) INTEGER IQ4SF,IQ3FS C C ================================= C ---- POUR LES TETRAEDRES ---- C ================================= C C =========================================== C ---- ITA2F(I,J) = ITA2F(J,I) = L'ARETE COMMUNE C AU FACES I ET J ET DIRECTE POUR I C A REVOIR C =========================================== ITA2F(1,1) = 0 ITA2F(2,1) = 4 ITA2F(3,1) = 2 ITA2F(4,1) = 3 C ITA2F(1,2) = 3 ITA2F(2,2) = 0 ITA2F(3,2) = 4 ITA2F(4,2) = 1 C ITA2F(1,3) = 4 ITA2F(2,3) = 1 ITA2F(3,3) = 0 ITA2F(4,3) = 2 C ITA2F(1,4) = 2 ITA2F(2,4) = 3 ITA2F(3,4) = 1 ITA2F(4,4) = 0 C C C =========================================== C ---- IT2FA(I,J) = FACE DIRECTE POUR L'ARETE I,J ---- C IT2FA(J,I) = FACE INDIRECTE C A REVOIR C =========================================== IT2FA(1,1) = 0 IT2FA(2,1) = 4 IT2FA(3,1) = 2 IT2FA(4,1) = 3 C IT2FA(1,2) = 3 IT2FA(2,2) = 0 IT2FA(3,2) = 4 IT2FA(4,2) = 1 C IT2FA(1,3) = 4 IT2FA(2,3) = 1 IT2FA(3,3) = 0 IT2FA(4,3) = 2 C IT2FA(1,4) = 2 IT2FA(2,4) = 3 IT2FA(3,4) = 1 IT2FA(4,4) = 0 C C ================================= C ---- IT3SF(I,J) = NOEUD I DE LA FACE J ---- C ================================= IT3SF(1,1) = 2 IT3SF(2,1) = 4 IT3SF(3,1) = 3 C IT3SF(1,2) = 3 IT3SF(2,2) = 4 IT3SF(3,2) = 1 C IT3SF(1,3) = 4 IT3SF(2,3) = 2 IT3SF(3,3) = 1 C IT3SF(1,4) = 1 IT3SF(2,4) = 2 IT3SF(3,4) = 3 C C ================================= C ---- POUR LES HEXAEDRES ---- C ================================= C C C ================================= C ---- IQ4SF(I,J) = NOEUD I DE LA FACE J ---- C ================================= C IQ4SF(1,1) = 1 IQ4SF(2,1) = 2 IQ4SF(3,1) = 3 IQ4SF(4,1) = 4 C IQ4SF(1,2) = 1 IQ4SF(2,2) = 5 IQ4SF(3,2) = 6 IQ4SF(4,2) = 2 C IQ4SF(1,3) = 2 IQ4SF(2,3) = 6 IQ4SF(3,3) = 7 IQ4SF(4,3) = 3 C IQ4SF(1,4) = 3 IQ4SF(2,4) = 7 IQ4SF(3,4) = 8 IQ4SF(4,4) = 4 C IQ4SF(1,5) = 4 IQ4SF(2,5) = 8 IQ4SF(3,5) = 5 IQ4SF(4,5) = 1 C IQ4SF(1,6) = 5 IQ4SF(2,6) = 8 IQ4SF(3,6) = 7 IQ4SF(4,6) = 6 C C ================================= C ---- IQ3FS(I,J) = FACE I AU NOEUD J ---- C ================================= C IQ3FS(1,1) = 1 IQ3FS(2,1) = 2 IQ3FS(3,1) = 5 C IQ3FS(1,2) = 2 IQ3FS(2,2) = 1 IQ3FS(3,2) = 3 C IQ3FS(1,3) = 3 IQ3FS(2,3) = 1 IQ3FS(3,3) = 4 C IQ3FS(1,4) = 4 IQ3FS(2,4) = 1 IQ3FS(3,4) = 5 C IQ3FS(1,5) = 2 IQ3FS(2,5) = 6 IQ3FS(3,5) = 5 C IQ3FS(1,6) = 3 IQ3FS(2,6) = 6 IQ3FS(3,6) = 2 C IQ3FS(1,7) = 4 IQ3FS(2,7) = 6 IQ3FS(3,7) = 3 C IQ3FS(1,8) = 5 IQ3FS(2,8) = 6 IQ3FS(3,8) = 4 C END C ***************************************************************** C MODULE : ST (STRUCTURE DES DONNEES) C FICHIER : ST_STRUCT.F C OBJET : CONSULTATION, CONSTRUCTION ET MODIFICATION DE LA C STRUCTURE DE DONNE DU MAILLAGE (1D, 2D, 3D) C FONCT. : C SUR LES MAILLAGES: C CONSTRUCTION : C SORIEN : ORIENTE UN MAILLAGE C SMACRE : CREER LA STRUCTURE DE DONNEE MAILLAGE C SFRICR : FRONTIERE (INTER MATERIAUX) CREEE DANS UN C MAILLAGE EXISTANT C SMADET : DETRUIT 1 ELEMENTS D'UN MAILLAGE C PARCOURS : C SESFR1: ELEMENT SUIVANT SUR FRONTIERE IDE-1 C SESFR2: ELEMENT PREMIER SUR FRONTIERE IDE-2 C SFRIDE : FRONTIERE IDE-1 COMMUNE AUX ELEMENTS C SUR LES MAILLES : C STRNBN : NOMBRE DE NOEUD DE L'ELEMENT C C AUTEUR : O. STAB C DATE : 03.95 C TESTS : O.STAB 03.95 C MODIFICATIONS : C AUTEUR, DATE, OBJET : O.STAB, 07.96, LE 3D (SMACRE,FAIDE,STRKFS) C AUTEUR, DATE, OBJET : O.STAB, 10.96, AJOUT DE NBPMAX DANS SMACRE C AUTEUR, DATE, OBJET : O.STAB, 04.97, BUG_15 (1D) + NETTOYAGE C AUTEUR, DATE, OBJET : O.STAB, 08.98, EXTRACTION DE ST_GENERIC.F C AUTEUR, DATE, OBJET : O.STAB, 01.05, modification de SFRICR C on traite une singularite en 2D IFR(1) C C ***************************************************************** C SUBROUTINE SORIEN(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NBE, > ITVL,NBITL,ITRAMA,NCC,IERR) C ***************************************************************** C OBJET : ORIENTE UN MAILLAGE C LES ELEMENTS DE CHAQUE COMPOSANTE CONNEXE SONT ORIENTES C DE LA MEME FACON C EN ENTREE: C IDE : (1..3) DIMENSION DES ELEMENTS C ITRNOE: LES NOEUDS DES ELEMENTS C NBNMAX : (2..8) NOMBRE DE NOEUDS MAXIMUM DES ELEMENTS C ITRTRI: LES VOISINS DES ELEMENTS C NBCMAX : (2..6) NOMBRE DE COTES MAXIMUM DES ELEMENTS C NBE : NOMBRE D'ELEMENTS DU MAILLAGE C ITVL,NBITL : TABLEAU DE TRAVAIL NBITL < (NBCMAX+1)*NBE C ITRAMA : " " " " DE TAILLE = NBE C EN SORTIE: C ITRNOE: MIS A JOUR C ITRTRI: MIS A JOUR C NCC : NOMBRE DE COMPOSANTES CONNEXES C IERR : CODE D'ERREUR 0 => OK C -1 => DONNEES INCOHERENTES C -2 => TABLEAU ITVL EST TROP PETIT C CONDITION D'APPLICATION : ARETE, TRIANGLE, QUADRANGLE, TETRA C ***************************************************************** INTEGER IDE,ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX,NBE INTEGER ITVL(*),NBITL,ITRAMA(*),NCC,IERR C DIMENSION ITT(7) EXTERNAL SFAIDE INTEGER SFAIDE INTEGER I,J,ITT,NBTRA,IP,IM,NOP,II,N1,N2 C NCC = 0 IERR = 0 IF( NBE.EQ. 0 )GOTO 9999 IF( NBE.LT. 0 )THEN IERR = -1 GOTO 9999 ENDIF IF( (NBCMAX+1).GT.NBITL )THEN IERR = -2 GO TO 9999 ENDIF C C INITIALISATION C -------------- DO 10 I=1,NBE ITRAMA(I) = 0 10 CONTINUE C C ON BOUCLE SUR LES COMPOSANTES CONNEXES C --------------------------------------- C DO 70 I=1,NBE IF( ITRAMA(I) .EQ. 0 )THEN NCC = NCC + 1 ITVL(1) = I DO 20 J=1,NBCMAX ITVL(J+1) = ITRTRI((I-1)*NBCMAX+J) 20 CONTINUE ITRAMA(I) = 1 NBTRA = NBCMAX+1 C C ON BOUCLE TANTQUE ITVL N'EST PAS VIDE C ---------------------------------------- C C TRANSFERT DU PERE TT(N+1) ET DE SES N VOISINS C --------------------------------------------- 30 DO 40 J=1,NBCMAX+1 ITT(J) = ITVL(NBTRA-J+1) 40 CONTINUE NBTRA = NBTRA-(NBCMAX+1) C C TRAITEMENT DES N VOISINS C ------------------------ DO 60 J=1,NBCMAX IF(( ITT(J) .NE. 0 ) .AND. (ITRAMA(ITT(J)) .NE. 1 )) THEN N1 = NBNMAX N2 = NBNMAX IF((NBNMAX.EQ.4).AND.(IDE.EQ.2))THEN C --- CAS D'UN MAILLAGE MIXTE QUADRANGLES, TRIANGLES-- IF(ITRNOE((ITT(J)-1)*NBNMAX+4).EQ.0)N1= 3 IF(ITRNOE((ITT(NBCMAX+1)-1)*NBNMAX+4).EQ.0)N2= 3 ENDIF NOP=SFAIDE(ITRNOE((ITT(J)-1)*NBNMAX+1), > ITRNOE((ITT(NBCMAX+1)-1)*NBNMAX+1),N1,N2,IDE,IM,IP) C IL Y A UN BUG C ------------- IF( NOP .EQ. 0 )THEN IERR = -1 GO TO 9999 ENDIF IF( NOP .LT. 0 ) THEN CALL SINVOR(IM,N1,IDE,ITRNOE((ITT(J)-1)*NBNMAX+1), > ITRTRI((ITT(J)-1)*NBCMAX+1)) ENDIF C SES VOISINS SERONT A TRAITER C ---------------------------- IF( (NBTRA+NBCMAX+1).GT.NBITL )THEN IERR = -2 GO TO 9999 ENDIF ITVL(NBTRA+1) = ITT(J) DO 50 II=1,NBCMAX ITVL(NBTRA+II+1) = ITRTRI(((ITT(J)-1)*NBCMAX)+II) 50 CONTINUE NBTRA = NBTRA + (NBCMAX+1) ITRAMA(ITT(J)) = 1 ENDIF 60 CONTINUE IF( NBTRA .GT. NBITL )THEN IERR = -2 GO TO 9999 ENDIF IF( NBTRA .NE. 0 )GO TO 30 ENDIF 70 CONTINUE 9999 END C C SUBROUTINE SMACRE(IDE,ITRI,NBE,NBPMAX, > ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,NOEMAX, > ITVL,NBTRAV,IERR) C ***************************************************************** C OBJET : CREER LA STRUCTURE DE DONNEE MAILLAGE C ITRI -> ITRNOE, ITRTRI, NOETRI C EN ENTREE: C IDE : (1..3) DIMENSION DES ELEMENTS C NBE : NOMBRE D'ELEMENTS DU MAILLAGE C NBPMAX : NOMBRE MAXIMUM DE POINTS C IL PEUT ETRE SUPERIEUR AUX NOEUDS CONNECTES DANS ITRI C 0 SI ON NE LE CONNAIT PAS C ITRI : ITRI(I,J) EST LE NOEUD J DE L'ELEMENT I C NBNMAX : (2..8) NOMBRE DE NOEUDS MAXIMUM DES ELEMENTS C NBCMAX : (2..6) NOMBRE DE COTES MAXIMUM DES ELEMENTS C NOEMAX : TAILLE DU TABLEAU NOETRI C SI NOEMEMAX = 0 NOETRI NE SERA PAS REMPLI C ITVL : TABLEAU DE TRAVAIL C NBTRAV : TAILLE DU TABLEAU DE TRAVAIL C AU MIN = 0 => O(N2) C AU MAX = (NBR MAX D'ELEMENTS EN 1 NOEUD + 1) * C (NUMERO MAXI DU NOEUD DANS ITRI) C => O(N) C EN SORTIE: C ITRNOE : ITRNOE(I,J) EST LE NOEUD J DU TRIANGLE I C LES ELEMENTS NE SONT PAS ORIENTES C PEUT ETRE LE MEME TABLEAU QUE ITRI C ITRTRI : ITRTRI(I,J) EST LE TRIANGLE INCIDENT AU TRIANGLE I SUR C L'ARETE J C NOETRI : NOETRI(I) EST UN DES TRIANGLES CONTENANT LE NOEUD I C IERR : CODE D'ERREUR 0 => OK C -NB => TABLEAU NOETRI TROP PETIT TAILLE SOUHAITE = NB C CONDITION D'APPLICATION : ARETE, TRIANGLE, QUADRANGLE, TETRA C ***************************************************************** INTEGER IDE,ITRI(*),NBE,NBPMAX INTEGER ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX INTEGER NOETRI(*), NOEMAX, ITVL(*), NBTRAV, IERR C EXTERNAL SFAIDE,STRKFS INTEGER SFAIDE,STRKFS INTEGER I,J,K, IT1,IT2, IT, NBNOE, N1,N2, NBTMAX, ITNV, NIJ C --- POUR LES TESTS --- C REAL*4 X(2),Z(3) INTEGER NBATST, NBLIN,IFAC(3),NBFN,KK,IFVUE C EXTERNAL ETIME C REAL*4 ETIME C IERR = 0 IF( NBE.EQ. 0 )GOTO 9999 IF( NBE.LT. 0 )THEN IERR = -1 GOTO 9999 ENDIF NBATST = 0 NBLIN = 0 C C ================ C ---- INITIALISATION ---- C ================ C DO 10 I=1,(NBE*NBCMAX) ITRTRI(I) = -1 10 CONTINUE NBNOE = 0 DO 20 I=1,(NBE*NBNMAX) IF( ITRI(I).GT.NBNOE )NBNOE = ITRI(I) 20 CONTINUE C C L'INDICE D'UN NOEUD DEPASSE LA TAILLE DU TABLEAU C C --- BUG10 25.10.96 ------------------------------- IF((NOEMAX.GT.0).AND. > ((NBNOE.GT.NOEMAX).OR.(NBPMAX.GT.NOEMAX)))THEN IERR = -2 GO TO 9999 ENDIF C --- INITIALISATION DU TABLEAU DE TRAVAIL --- NBTMAX = NBTRAV / NBNOE C MODIF O.STAB 1.9.99 : POUR LIMITER LE TRAITEMENT C ET NE PAS INITIALISER TOUT ITVL !!!!!! NBTMAX = MIN( NBE, NBTMAX ) IF( NBTMAX .LT. 2 )GO TO 90 DO 30 I=1,(NBNOE * NBTMAX) ITVL(I) = 0 30 CONTINUE C C ============================= C ---- CALCUL DES VOISINS : ITRTRI ---- C ============================= C C Z(1) =ETIME(X) DO 50 I=1,NBE C ---------------------------------------------------------- C REMPLISSAGE LINEAIRE MAIS PROBABILISTE (2/5) DES VOISINS C PRINCIPE : SI UN AUTRE ELEMENT PARTAGE UN NOEUD AVEC C UN AUTRE ELEMENT, ALORS PEUT ETRE PARTAGE T'IL UNE ARETE ? C ---------------------------------------------------------- C N1 = NBNMAX IF( (NBNMAX.EQ.4).AND.(IDE.EQ.2).AND. > (ITRI((I-1)*NBNMAX+4).EQ.0))N1= 3 DO 40 J=1,N1 IT = ITRI((I-1)*NBNMAX+J) IF(IT.LE.0)GOTO 40 K = ITVL((IT-1)*NBTMAX+1) IF(K.LT.(NBTMAX-1))THEN ITVL((IT-1)*NBTMAX+1) = K+1 ITVL((IT-1)*NBTMAX+K+2)= I ENDIF 40 CONTINUE 50 CONTINUE C C NBLIN = 0 DO 80 I=1,NBE N1 = NBNMAX C --- BUG6 05.09.96 : ITRTRI(4) = 0 ----- IF( (IDE.EQ.2).AND.(NBNMAX.EQ.4).AND. > (ITRI((I-1)*NBNMAX+4).EQ.0))THEN N1= 3 ITRTRI((I-1)*NBCMAX + 4) = 0 ENDIF * WRITE(*,*)' ELEMENT ',I DO 70 J=1,N1 C C POUR TOUTES LES FACES INCIDENTES AU NOEUD J C NBFN = STRKFS(IDE,J,N1,IFAC) * WRITE(*,*)' NOEUD = ',J DO 55 K=1,NBFN * WRITE(*,*)' IFAC(',K,') = ',IFAC(K) * WRITE(*,*)' VOISIN = ',ITRTRI((I-1)*NBCMAX + IFAC(K)) IF( ITRTRI((I-1)*NBCMAX + IFAC(K)).EQ.-1)GOTO 56 55 CONTINUE GOTO 70 C --- REMPLACE : C IF( ITRTRI((I-1)*NBCMAX + J).EQ.0)THEN C 56 IT = ITRI((I-1)*NBNMAX+J) * WRITE(*,*) 'ON TESTE LE NOEUD ',J,' DE L ELEMENT ',I IF(IT.LE.0)GOTO 70 C ---- DANS LE TABLEAU DES ELEMENTS INCIDENTS --- * WRITE(*,*)'LISTE =' DO 65 K=1,ITVL((IT-1)*NBTMAX+1) ITNV = ITVL((IT-1)*NBTMAX+K+1) * WRITE(*,*)'ELEMENT SUR ',J,' ITNV = ',ITNV IF(ITNV.NE.I)THEN N2 =NBNMAX IF( (NBNMAX.EQ.4).AND.(IDE.EQ.2).AND. > (ITRI((ITNV-1)*NBNMAX+4).EQ.0))N2= 3 IF(SFAIDE(ITRI((I-1)*NBNMAX+1), > ITRI((ITNV-1)*NBNMAX+1), > N1,N2,IDE,IT1,IT2 ).NE.0)THEN * WRITE(*,*) ITNV,' ET ',I,' SONT ADJACENTS SUR ',IT1,IT2 ITRTRI((I-1)*NBCMAX + IT1) = ITNV ITRTRI((ITNV-1)*NBCMAX + IT2) = I NBLIN = NBLIN + 1 ENDIF ENDIF 65 CONTINUE C ENDIF 70 CONTINUE 80 CONTINUE C Z(2) = ETIME( X ) C C ---------------------------------------------------------- C REMPLISSAGE EN O(N2) DES VOISINS C ---------------------------------------------------------- C 90 NBATST = 0 C ------------------------------- POUR TOUTES LES MAILLES: I DO 100 I=1,NBE-1 N1 = NBNMAX IF( (NBNMAX.EQ.4).AND.(IDE.EQ.2).AND. > (ITRI((I-1)*NBNMAX+4).EQ.0))N1= 3 C C ------(A) PRE-TRAITEMENT DES FACES INCIDENTES AUX NOEUDS C ----------------- POUR TOUS LES NOEUDS DE LA MAILLE I: J DO 110 J=1,N1 IT = ITRI((I-1)*NBNMAX+J) IF(IT.LE.0)GOTO 110 C ---------------------------------------- C ---- AUCUNE MAILLE INCIDENTE A J N'A DE FACE C COMMUNE AVEC I : ON LES A TOUTES TESTEES : C ON EST SUR LA FRONTIERE ---- C ---------------------------------------- IF((NBTMAX.GT.2).AND. > (ITVL((IT-1)*NBTMAX+1).LT.(NBTMAX-1)))THEN NBFN = STRKFS(IDE,J,N1,IFAC) DO 91 KK=1,NBFN IF( ITRTRI((I-1)*NBCMAX + IFAC(KK)).EQ.-1) > ITRTRI((I-1)*NBCMAX + IFAC(KK)) = 0 91 CONTINUE ENDIF C ----------------------------------- FIN DE BOUCLE SUR J 110 CONTINUE C C -----(B) TRAITEMENT SYSTEMATIQUE DES FACES NON VISITEES C ------------------------------------------------------- C RECHERCHE D'UNE FACE DE LA MAILLE I NON ENCORE VISITEE C ------------------------------------------------------- IFVUE = 0 DO 95 KK=1,NBCMAX IF( ITRTRI((I-1)*NBCMAX + KK).EQ.-1)IFVUE=IFVUE+1 95 CONTINUE C C ------------------------------------------------------- C IL EXISTE UNE FACE DE LA MAILLE I NON ENCORE VISITEE C ON PARCOURS TOUTES LES MAILLES DE KK=I+1 A NBE C ------------------------------------------------------- IF(IFVUE.GT.0)THEN NBATST = NBATST+1 C ------------------ POUR TOUS LE ELEMENTS DE I A NBE: K DO 120 K=I+1,NBE N2 = NBNMAX IF( (NBNMAX.EQ.4).AND.(IDE.EQ.2).AND. > (ITRI((K-1)*NBNMAX+4).EQ.0))N2= 3 IF(SFAIDE(ITRI((I-1)*NBNMAX+1), > ITRI((K-1)*NBNMAX+1), > N1,N2,IDE,IT1,IT2).NE.0) > THEN ITRTRI((I-1)*NBCMAX + IT1) = K ITRTRI((K-1)*NBCMAX + IT2) = I ENDIF 120 CONTINUE C -------------------------- FIN DE BOUCLE DE I A NBE: K C C ------------- LES FACES JAMAIS VISITEES SONT FRONTIERE DO 196 KK=1,NBCMAX IF( ITRTRI((I-1)*NBCMAX + KK).EQ.-1) > ITRTRI((I-1)*NBCMAX + KK) = 0 196 CONTINUE ENDIF 100 CONTINUE C ----------------- PARCOURS DES FACES DU DERNIER ELEMENT DO 197 KK=1,NBCMAX IF( ITRTRI((NBE-1)*NBCMAX + KK).EQ.-1) > ITRTRI((NBE-1)*NBCMAX + KK) = 0 197 CONTINUE C C Z(3)=ETIME(X) C -------------------------------------------- C PRINT *,'NB DE TRIANGLES STOQUES = ',NBTMAX C PRINT *,'NB EN QUADRATIQUE = ',NBATST C PRINT *,'NB LINEAIRE = ',NBLIN C PRINT *,'NB TOTAL = ',(NBE*NBCMAX) C PRINT *,'TEMPS LINEAIRE = ',(Z(2)-Z(1)) C PRINT *,'TEMPS QUADRATI = ',(Z(3)-Z(2)) C C INITIALISATION DE ITRNOE C ------------------------- DO 130 I=1,(NBE*NBNMAX) ITRNOE(I) = ITRI(I) 130 CONTINUE C C INITIALISATION DE NOETRI C ------------------------- IF(NOEMAX.GT.0)THEN DO 135 I=1,MAX(NBNOE,NBPMAX) NOETRI(I) = 0 135 CONTINUE DO 140 I=1,NBE C --- BUG17 AJOUT DE LA LIGNE QUI SUIT O.STAB 07/02/96 N1 = NBNMAX IF( (NBNMAX.EQ.4).AND.(IDE.EQ.2).AND. > (ITRI((I-1)*NBNMAX+4).EQ.0))N1= 3 DO 150 J=1, N1 NIJ = ITRI((I-1)*NBNMAX+J) IF(NIJ.GT.0)NOETRI(NIJ) = I 150 CONTINUE 140 CONTINUE ENDIF C ---- POUR LE DEBUG ---------------------------------- * CALL PRITAB('ITRINOE ',ITRNOE,NBE,NBNMAX,1) * CALL PRITAB('ITRITRI ',ITRTRI,NBE,NBCMAX,1) * CALL PRITAB('NOETRI ',NOETRI,NBNOE,1,1) C 9999 END C C SUBROUTINE SFRICR(IFR,NBIFR,IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX, > NOETRI,NBE,ITVL,NITMAX,IERR) C > NOETRI,NBE,IERR) C **************************************************************** C OBJET SFRICR : FRONTIERE (INTER MATERIAUX) CREEE DANS UN MAILLAGE C AJOUT D'UN SOMMET, D'UNE ARETE OU D'UNE FACETTE A LA FRONTIERE C INTER-MATERIAUX. C EN ENTREE: C IFR : TABLEAU DES NOEUDS DE L'ELEMENT FRONTIERE C NBIFR : NOMBRE DE NOEUDS DE L'ELEMENT FRONTIERE C IDE : (1..3) DIMENSION DES ELEMENTS C ITRNOE: LES NOEUDS DES ELEMENTS C NBNMAX : (2..8) NOMBRE DE NOEUDS MAXIMUM DES ELEMENTS C ITRTRI: LES VOISINS DES ELEMENTS C NBCMAX : (2..6) NOMBRE DE COTES MAXIMUM DES ELEMENTS C NOETRI : TABLEAU DES ELEMENTS INCIDENT AUX NOEUDS C NBE : NOMBRE D'ELEMENTS DU MAILLAGE C EN SORTIE: C ITRTRI: MIS A JOUR C IERR : CODE D'ERREUR 0 => OK, -1 => L'ELEMENT FRONTIERE C N'EXISTE PAS DANS LE MAILLAGE C CONDITION D'APPLICATION : C **************************************************************** INTEGER IFR(*),NBIFR INTEGER IDE,ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX,NOETRI(*),NBE INTEGER ITVL(*),NITMAX INTEGER IERR C INTEGER IT1, IT2, I1, I2 INTEGER IFR1 C IERR = 0 CALL SFRIDE(IFR,NBIFR,IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX, > NOETRI,NBE,ITVL,NITMAX,IT1,IT2,I1,I2,IERR) IF(( IT1 .EQ. 0 ) .AND. ( IT2 .EQ. 0 ))THEN C L'ARETE IFR(1),IFR(2) (ou LA FACETTE IFR(1),IFR(2),IFR(3)) N'EXISTE PAS IF( NBIFR.NE.2 )THEN IERR = -1 GOTO 9999 ENDIF C on essaye un truc pour traiter une singularite en IFR(1) !!! 01.2005 C la singularite est en IFR(1), on va tourner sur IFR(2) => il faut les permuter. IFR1 = IFR(1) IFR(1) = IFR(2) IFR(2) = IFR1 CALL SFRIDE(IFR,NBIFR,IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX, > NOETRI,NBE,ITVL,NITMAX,IT1,IT2,I1,I2,IERR) IF(( IT1 .EQ. 0 ) .AND. ( IT2 .EQ. 0 ))THEN IERR = -1 GOTO 9999 ENDIF ENDIF C IF(( IT1 .GT. 0 ) .AND. ( IT2 .GT. 0 ))THEN IF(ITRTRI((IT1-1)*NBCMAX+I1).GT.0) > ITRTRI((IT1-1)*NBCMAX+I1) = -ITRTRI((IT1-1)*NBCMAX+I1) IF(ITRTRI((IT2-1)*NBCMAX+I2).GT.0) > ITRTRI((IT2-1)*NBCMAX+I2) = -ITRTRI((IT2-1)*NBCMAX+I2) ENDIF C 9999 END C SUBROUTINE SESFR1(IT,IAR,ITRTRI,NBCMAX,IT2,IAR2) C ******************************************************* C OBJET SESFR1 : ELEMENT SUIVANT SUR FRONTIERE IDE-1 C TRIANGLE SUIVANT SUR ARETE / TETRA SUIVANT SUR FACE C EN ENTREE: C IT : LE TRIANGLE INITIAL C IAR : L'ARETE INITIALE DE IT C NBCMAX : NOMBRE DE COTES MAXIMUM DES ELEMENTS DU MAILLAGE C ITRTRI: TABLEAU DES VOISINS C EN SORTIE: C IT1 : LE TRIANGLE SUIVANT C IAR1: INDICE DE L'ARETE IAR POUR LE TRIANGLE IT1 C CONDITION D'APPLICATION : TRIANGLE, QUADRANGLE, TETRA C REMARQUE : NE CONSIDERE PAS LES FRONTIERES INTERNES C ******************************************************* INTEGER IT,IAR,NBCMAX,ITRTRI(*),IT2,IAR2 C INTEGER J,IT1,IAR1,IT0 C IAR1 = 0 IT1 = ITRTRI((IT-1)*NBCMAX+IAR) IF( IT1 .EQ. 0 )GO TO 20 IF( IT1 .LT. 0 )IT1 = -IT1 C --- RECHERCHE DE L'ARETE IAR1 DE IT1 --- DO 10 J=1,NBCMAX IT0 = ITRTRI((IT1-1)*NBCMAX + J) IF( IT0.LT. 0 )IT0 = -IT0 IF( IT0 .EQ. IT )THEN IAR1 = J GO TO 20 ENDIF 10 CONTINUE 20 IT2 = IT1 IAR2 = IAR1 999 END C SUBROUTINE SESFR2(NN,ISENS,IDE,ITRNOE,NBNMAX,ITRTRI, > NBCMAX,NOETRI,ITP,IAR) C ************************************************************ C OBJET SESFR2 : ELEMENT PREMIER SUR FRONTIERE IDE-2 C TRIANGLE PREMIER SUR SOMMET / TETRA PREMIER SUR ARETE C RECHERCHE DU TRIANGLE DE DEPART ET DE SON ARETE POUR C TOURNER AUTOUR D'UN SOMMET DANS UN SENS DONNE C EN ENTREE: C NN : LE SOMMET OU L'ARETE SUR LEQUEL ON TOURNE C ISENS : LE SENS DANS LEQUEL ON VEUT TOURNER C EN SORTIE: C ITP : LE TRIANGLE DE DEPART C IAR : INDICE DE L'ARETE DE DEPART POUR LE TRIANGLE IPT C -1 SI "NN" N'APPARTIENT PAS A L'ELEMENT C REMARQUE : NE CONSIDERE PAS LES FRONTIERES INTERNES C ************************************************************ INTEGER NN(*),ISENS,IDE,ITRNOE(*),NBNMAX,ITRTRI(*) INTEGER NBCMAX,NOETRI(*),ITP,IAR C INTEGER IT,JJ,J,IDEBUT,IAR1,ISOM(2),NBNE INTEGER STRNBN EXTERNAL STRNBN C ITP = 0 IDEBUT = NOETRI(NN(1)) IT = IDEBUT C C --- ON RECHERCHE LE PREMIER NOEUD : NN --- C IAR = 0 IAR1 = 0 ISOM(1) = 0 ISOM(2) = 0 DO 15 JJ=1,(IDE-1) DO 10 J=1,NBNMAX IF(ITRNOE((IT-1)*NBNMAX+J) .EQ. NN(JJ))THEN ISOM(JJ) = J GOTO 15 ENDIF 10 CONTINUE IAR = -1 GOTO 9999 15 CONTINUE IF( ISOM(IDE-1).EQ.0 )THEN IAR = -1 GOTO 9999 ENDIF C IF( NBNMAX.EQ.3 )THEN NBNE = NBNMAX ELSE NBNE = STRNBN(IT,ITRNOE,NBNMAX) ENDIF CALL STFASU(IDE,NBNE,ISOM,IAR1) C C IF(ITRNOE((IT-1)*NBNMAX+J) .EQ. NN(1))THEN C IF( IDE .EQ. 2 )THEN C IF( NBNMAX.EQ.3 )THEN C IAR1 = MOD(J+(NBNMAX-2),NBNMAX)+1 C ELSE C NBNE = STRNBN(IT,ITRNOE,NBNMAX) C IAR1 = MOD(J+(NBNE-2),NBNE)+1 C ENDIF C GO TO 20 C ELSE C --- CAS 3D --- C DO 3 K=1,NBNMAX C IF( ITRNOE((IT-1)*NBNMAX+K).EQ.0 )GO TO 4 C 3 CONTINUE C 4 NBRN = K C DO 5 K=1,NBRN C IF(ITRNOE((IT-1)*NBNMAX+K) .EQ. NN(2))THEN C --- FACE DIRECTE OU INDIRECTE INCIDENTE A L'ARETE JK C CALL S3FDIA(J,K,NBRN,IAR1) C GO TO 20 C ENDIF C 5 CONTINUE C ENDIF C ENDIF C 10 CONTINUE C ---- ON A PAS TROUVER L'ARETE OU LA FACE --- C IAR = -1 C GO TO 999 C 20 ITP = IT IAR = IAR1 C IF( ISENS .EQ. 1)IAR = MOD(IAR+(NBNMAX-2),NBNMAX)+1 CALL SESFR1(ITP,IAR,ITRTRI,NBCMAX,IT,IAR1) IF( IT .EQ. 0 )GO TO 9999 C --- ON PASSE AU TRIANGLE SUIVANT,ARETE PREC --- C IAR1 = MOD(IAR1+(NBNMAX-2),NBNMAX)+1 C REMPLACER PAR O.STAB BUG 8 : C IF( NBNMAX.EQ.3 )THEN IAR1 = MOD(IAR1+(NBNMAX-2),NBNMAX)+1 ELSE NBNE = STRNBN(IT,ITRNOE,NBNMAX) IAR1 = MOD(IAR1+(NBNE-2),NBNE)+1 ENDIF IF( IT .NE. IDEBUT )GO TO 20 9999 END C C SUBROUTINE SFRIDE(NN,NBNN, > IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX, > NOETRI,NBE,ITVL,NITMAX, > IT1,IT2,I1,I2,IERR) C ************************************************************* C OBJET SFRIDE : ELEMENT INCIDENT SUR UNE FACE (IDE-1) C RECHERCHE DES TRIANGLES QUI PARTAGENT L'ARETE NN(1..2) C RECHERCHE DES TETRAEDRES QUI PARTAGENT LE TRIANGLE NN(1..3) C C EN ENTREE: C NN : TABLEAU DES SOMMETS DE LA FACE C NBNN : NOMBRE DE SOMMETS DE LA FACE C IDE : DIMENSION DES ELEMENTS DU MAILLAGE C NBE : NOMBRE D'ELEMENTS DU MAILLAGE C ITVL,NITMAX : TABLEAU DE TRAVAIL (NECESSAIRE SEULEMENT EN 3D) C C EN SORTIE: C IT1 : L'ELEMENT QUI CONTIENT LA FACE NN(1),NN(2)... C I1 : L'INDICE DE LA FACE DE L'ELEMENT C IT2 : L'ELEMENT QUI CONTIENT LA FACE ...NN(2),NN(1) C I2 : L'INDICE DE LA FACE DE L'ELEMENT C REMARQUE : NE PREND PAS EN COMPTE LES FRONTIERES INTERNES C SFRI3D POUR LE 3D, SFRI2D POUR LE 2D, SFRI1D... C ATTENTION : NOETRI EST OBLIGATOIRE !!! C ************************************************************* INTEGER NN(*),NBNN INTEGER IDE,ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX INTEGER NOETRI(*),NBE,ITVL(*),NITMAX INTEGER IT1,IT2,I1,I2,IERR C GOTO(10,20,30) IDE IERR = -1 GOTO 9999 C ---- CAS 1D ET 2D : 10 CONTINUE CALL SFRI1D(NN,NBNN, > IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX, > NOETRI,NBE,ITVL,NITMAX, > IT1,IT2,I1,I2,IERR) GOTO 9999 20 CONTINUE CALL SFRI2D(NN,NBNN, > IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX, > NOETRI,NBE,ITVL,NITMAX, > IT1,IT2,I1,I2,IERR) GOTO 9999 C --- CAS 3D : 30 CONTINUE CALL SFRI3D(NN,NBNN, > IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX, > NOETRI,NBE,ITVL,NITMAX, > IT1,IT2,I1,I2,IERR) C 9999 END C C SUBROUTINE SFRIDE(NN,NBNN,IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX, C > NOETRI,NBE,IT1,IT2,I1,I2) C MODIF SFRIDE EXTENSION 3D : CHANGEMENT SIGNATURE SUBROUTINE SFRI1D(NN,NBNN, > IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX, > NOETRI,NBE,ITVL,NITMAX, > IT1,IT2,I1,I2,IERR) C ************************************************************* C OBJET SFRI1D : RECHERCHE DES ARETES PARTAGEANT UN SOMMET NN(1) C C EN ENTREE: C NN : TABLEAU DES SOMMETS DE L'ELEMENT FRONTIERE C NBNN : NOMBRE DE SOMMETS C IDE : DIMENSION DES ELEMENTS DU MAILLAGE C NBE : NOMBRE D'ELEMENTS DU MAILLAGE C C EN SORTIE: C IT1 : LE TRIANGLE QUI CONTIENT L'ARETE NN(1),NN(2) C I1 : L'INDICE DE L'ARETE DE IT1 EGALE A NN(1),NN(2) C IT2 : LE TRIANGLE QUI CONTIENT L'ARETE NN(2),NN(1) C I2 : L'INDICE DE L'ARETE DE IT2 EGALE A NN(2),NN(1) C REMARQUE : 2D SEULEMENT (TRIANGLES, QUADRANGLES, MIXTE) C NE PREND PAS EN COMPTE LES FRONTIERES INTERNES C SFRI3D POUR LE 3D C IL FAUDRAIT AJOUTER UN TABLEAU DE TRAVAIL POUR C AVOIR LA MEME SIGNATURE C ************************************************************* INTEGER NN(*),NBNN INTEGER IDE,ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX INTEGER NOETRI(*),NBE,ITVL(*),NITMAX INTEGER IT1,IT2,I1,I2,IERR C INTEGER J1,J2,ISENS,IT,J,IDEBUT,NNT,ITAMPO INTEGER STRNBN EXTERNAL STRNBN C IT1 = 0 IT2 = 0 I1 = 0 I2 = 0 IERR = 0 IF( IDE.NE.1 )THEN IERR = -3 CALL DSERRE(1,IERR,'SFRI1D',' NE FONCTIONNE QU EN 1D') GOTO 9999 ENDIF ISENS = 1 C --- BOUCLE SUR LE SENS 10 CONTINUE IDEBUT = NOETRI(NN(1)) IT = IDEBUT C --- NOEUD ISOLE IF( IT.EQ.0 )GOTO 9999 C C --- ON RECHERCHE LE PREMIER NOEUD : NN(1) --- C 20 CONTINUE J1 = 0 DO 30 J=1,NBNMAX IF(ITRNOE((IT-1)*NBNMAX+J) .EQ. NN(1))J1 = J 30 CONTINUE C --- L'ELEMENT NE CONTIENT PAS LE NOEUD / BUG STRUCTURE IF(J1.EQ.0)THEN IERR = -1 CALL DSERRE(1,IERR,'SFRI1D','STRUCTURE INCORRECTE') GO TO 9999 ENDIF C ---------------------------------------------------- C SENS DIRECT => ARETE PARTANT DU NOEUD N1 C SENS INDIRE => ARETE ARRIVANT AU NOEUD => ARETE PREC C ---------------------------------------------------- C EN 2D LE NOMBRE DE COTE = NOMBRE DE NOEUDS NNT = STRNBN(IT,ITRNOE,NBNMAX) IF( ISENS .EQ. -1 )J1 = MOD(J1+(NNT-2),NNT)+1 IT1 = IT I1 = J1 IT2 = ITRTRI((IT1-1)*NBCMAX+J1) IF( IT2 .EQ. 0 )GO TO 9999 IF( IT2 .LT. 0 )IT2 = -IT2 DO 110 J=1,NBNMAX IF( NN(1) .EQ. ITRNOE((IT2-1)*NBNMAX+J))THEN I2 = J GOTO 9999 ENDIF 110 CONTINUE C --- ERREUR --- IERR = -1 CALL DSERRE(1,IERR,'SFRI1D','STRUCTURE INCORRECTE 2') C 9999 END C SUBROUTINE SFRI2D(NN,NBNN, > IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX, > NOETRI,NBE,ITVL,NITMAX, > IT1,IT2,I1,I2,IERR) C ************************************************************* C OBJET SFRI2D : FRONTIERE IDE-1 COMMUNE AUX ELEMENTS C RECHERCHE DES TRIANGLES QUI PARTAGENT L'ARETE NN(1..2) C C EN ENTREE: C NN : TABLEAU DES SOMMETS DE L'ELEMENT FRONTIERE C NBNN : NOMBRE DE SOMMETS C IDE : DIMENSION DES ELEMENTS DU MAILLAGE C NBE : NOMBRE D'ELEMENTS DU MAILLAGE C C EN SORTIE: C IT1 : LE TRIANGLE QUI CONTIENT L'ARETE NN(1),NN(2) C I1 : L'INDICE DE L'ARETE DE IT1 EGALE A NN(1),NN(2) C IT2 : LE TRIANGLE QUI CONTIENT L'ARETE NN(2),NN(1) C I2 : L'INDICE DE L'ARETE DE IT2 EGALE A NN(2),NN(1) C REMARQUE : 2D SEULEMENT (TRIANGLES, QUADRANGLES, MIXTE) C NE PREND PAS EN COMPTE LES FRONTIERES INTERNES C SFRI3D POUR LE 3D C IL FAUDRAIT AJOUTER UN TABLEAU DE TRAVAIL POUR C AVOIR LA MEME SIGNATURE C ************************************************************* INTEGER NN(*),NBNN INTEGER IDE,ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX INTEGER NOETRI(*),NBE,ITVL(*),NITMAX INTEGER IT1,IT2,I1,I2,IERR C INTEGER J1,J2,ISENS,IT,J,IDEBUT,NNT,ITAMPO INTEGER STRNBN EXTERNAL STRNBN C IT1 = 0 IT2 = 0 I1 = 0 I2 = 0 IERR = 0 IF( IDE.NE.2 )THEN IERR = -3 CALL DSERRE(1,IERR,'SFRI2D',' NE FONCTIONNE PAS EN 3D') GOTO 9999 ENDIF ISENS = 1 C --- BOUCLE SUR LE SENS 10 CONTINUE IDEBUT = NOETRI(NN(1)) IT = IDEBUT C --- NOEUD ISOLE IF( IT.EQ.0 )GOTO 9999 C C --- ON RECHERCHE LE PREMIER NOEUD : NN(1) --- C 20 CONTINUE J1 = 0 DO 30 J=1,NBNMAX IF(ITRNOE((IT-1)*NBNMAX+J) .EQ. NN(1))J1 = J 30 CONTINUE C --- L'ELEMENT NE CONTIENT PAS LE NOEUD / BUG STRUCTURE IF(J1.EQ.0)THEN IERR = -1 CALL DSERRE(1,IERR,'SFRI2D','STRUCTURE INCORRECTE') GO TO 9999 ENDIF C ---------------------------------------------------- C SENS DIRECT => ARETE PARTANT DU NOEUD N1 C SENS INDIRE => ARETE ARRIVANT AU NOEUD => ARETE PREC C ---------------------------------------------------- C EN 2D LE NOMBRE DE COTE = NOMBRE DE NOEUDS NNT = STRNBN(IT,ITRNOE,NBNMAX) C --- ON RECHERCHE LE DEUXIEME NOEUD : NN(2) --- IF( ISENS .EQ. 1 )THEN C --- ARETE PARTANT DU NOEUD N1 =>TEST DU NOEUD EXTREMITE J2 = MOD(J1,NNT)+1 ELSE C --- ARETE ARRIVANT AU NOEUD N1 =>TEST DU NOEUD ORIGINE J1 = MOD(J1+(NNT-2),NNT)+1 J2 = J1 ENDIF IF( NN(2) .EQ. ITRNOE((IT-1)*NBNMAX+J2))THEN IT1 = IT I1 = J1 IT2 = ITRTRI((IT1-1)*NBCMAX+J1) IF( IT2 .EQ. 0 )THEN IF( ISENS.EQ.1 )GOTO 9999 C --- BUG5 POUR RESPECTER L'ORIENTATION NN(1),NN(2) IT2 = IT1 I2 = I1 I1 = 0 IT1 = 0 GO TO 9999 ENDIF IF( IT2 .LT. 0 )IT2 = -IT2 DO 210 J=1,NBNMAX IF((ISENS.EQ.1).AND. > (NN(2).EQ.ITRNOE((IT2-1)*NBNMAX+J)))THEN I2 = J GOTO 9999 ENDIF C --- BUG5 POUR RESPECTER L'ORIENTATION NN(1),NN(2) IF((ISENS.EQ.-1).AND. > (NN(1).EQ.ITRNOE((IT2-1)*NBNMAX+J)))THEN I2 = J ITAMPO = IT1 IT1 = IT2 IT2 = ITAMPO ITAMPO = I1 I1 = I2 I2 = ITAMPO GOTO 9999 ENDIF 210 CONTINUE C --- ERREUR --- IERR = -1 CALL DSERRE(1,IERR,'SFRI2D','STRUCTURE INCORRECTE 3') GOTO 9999 ENDIF C C --- ON PASSE AU TRIANGLE SUIVANT --- C IT = ITRTRI((IT-1)*NBCMAX+J1) IF( IT .EQ. 0 )THEN IF( ISENS .EQ. 1 )THEN C --- ON EST ARRIVE SUR LA FRONTIERE : ON CHANGE DE SENS --- ISENS = -1 GO TO 10 ELSE C --- ON ARRIVE SUR LA FRONTIERE EN TOURNANT DANS LES 2 SENS --- GOTO 9999 ENDIF ELSE IF( IT .LT. 0 )THEN IT = -IT ENDIF ENDIF IF( IT .NE. IDEBUT )THEN GO TO 20 ENDIF C 9999 END C FUNCTION STRNBN(IT,ITRNOE,NBNMAX) C ************************************************************* C OBJET STRNBN : RENVOI LE NOMBRE REEL DE NOEUD DE L'ELEMENT IT C ************************************************************* INTEGER STRNBN INTEGER IT,ITRNOE(*),NBNMAX C STRNBN = 0 10 IF( ITRNOE((IT-1)*NBNMAX + STRNBN + 1).EQ.0 )GO TO 999 STRNBN = STRNBN + 1 IF( (STRNBN+1).GT.NBNMAX )GO TO 999 GO TO 10 999 END C SUBROUTINE SMADET(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NBE,NOETRI, > NOEMAX,IT1,N,ISOMP,NBSOMP,IERR) C ***************************************************************** C OBJET SMADET : DETRUIT 1 ELEMENTS D'UN MAILLAGE C EN ENTREE: C IDE : (1..3) DIMENSION DES ELEMENTS C ITRNOE: LES NOEUDS DES ELEMENTS C NBNMAX : (2..8) NOMBRE DE NOEUDS MAXIMUM DES ELEMENTS C ITRTRI: LES VOISINS DES ELEMENTS C NBCMAX : (2..6) NOMBRE DE COTES MAXIMUM DES ELEMENTS C NBE : NOMBRE D'ELEMENTS DU MAILLAGE C NOEMAX MISE A JOUR DE NOETRI SI NON NUL C IT1 : L'ELEMENTS A DETRUIRE C N : NOMBRE DE NOEUDS DE L'ELEMENT IT1 C EN SORTIE: C ITRNOE: MIS A JOUR C ITRTRI: MIS A JOUR C NOETRI : MIS A JOUR C IERR : CODE D'ERREUR 0 => OK C -1 => DONNEES INCOHERENTES C CONDITION D'APPLICATION : TOUT MAILLAGE AVEC UNE RESTRICTION C LA DESTRUCTION DE LA MAILLE NE DOIT PAS CREER DE SINGULARITES C SUR LA FRONTIERE (SINON NOETRI() N'EST PLUS VALIDE). C C ***************************************************************** INTEGER IDE,ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX,NOETRI(*),NBE INTEGER NOEMAX, IT1, N, ISOMP(*), NBSOMP, IERR C INTEGER I,J,ITR,NBFAC,IFAC(4) INTEGER STRKFS EXTERNAL STRKFS C IERR = 0 IF((IT1.LT.1).OR.(IT1.GT.NBE))THEN IERR = -1 GO TO 999 ENDIF C C ---- MISE A JOUR DES NOEUDS FAISANT REFERENCE A IT1 --- C IF( NOEMAX.NE.0 )THEN DO 20 I=1,NBNMAX IF( NOETRI(ITRNOE((IT1-1)*NBNMAX+I)) .EQ. IT1 )THEN NBFAC = STRKFS(IDE,I,N,IFAC) DO 5 J=1,NBFAC ITR = ITRTRI((IT1-1)*NBCMAX+IFAC(J)) IF(ITR.NE.0)GO TO 10 5 CONTINUE C --- UN SOMMET EST PERDU --- NBSOMP = NBSOMP+1 ISOMP(NBSOMP) = ITRNOE((IT1-1)*NBNMAX+I) 10 NOETRI(ITRNOE((IT1-1)*NBNMAX+I)) = ITR ENDIF 20 CONTINUE ENDIF C C ---- MISE A JOUR DES ELEMENTS VOISINS DE IT1 --- C DO 30 I=1,NBCMAX ITR = ITRTRI((IT1-1)*NBCMAX+I) IF(ITR.NE.0)THEN IF( ITR .LT. 0 )ITR = - ITR DO 40 J=1,NBCMAX IF((ITRTRI((ITR-1)*NBCMAX+J).EQ.IT1) .OR. > (ITRTRI((ITR-1)*NBCMAX+J).EQ.-IT1) )THEN ITRTRI((ITR-1)*NBCMAX+J) = 0 GO TO 30 ENDIF 40 CONTINUE C --- IL Y A UN BUG DANS LA STRUCTURE --- IERR = -2 GO TO 999 ENDIF 30 CONTINUE C ---------- INITIALISATION DE IT1 ---------- DO 90 I=1,NBCMAX ITRTRI((IT1-1)*NBCMAX+I)=0 90 CONTINUE DO 100 I=1,NBNMAX ITRNOE((IT1-1)*NBNMAX+I)=0 100 CONTINUE C ------------------ 999 END C C ***************************************************************** C MODULE : ST (STRUCTURE DES DONNEES) C FICHIER : ST_GENERIC.F C OBJET : CONSULTATION, CONSTRUCTION ET MODIFICATION DE LA C STRUCTURE DE DONNE DU MAILLAGE (1D, 2D, 3D) C FONCT. : C SUR LES MAILLAGES: C CONSTRUCTION : C SINVOR : INVERSE L'ORIENTATION D'UN ELEMENT C SORIEN : ORIENTE UN MAILLAGE C PARCOURS : C SFAIDE : RECHERCHE LA FACE COMMUME A 2 ELEMENTS C SUR LES MAILLES : C STINIT : INITIALISATION DES STRUCTURES DE DELOS C STRNBC : NOMBRE DE COTE DE L'ELEMENT C STRKFS : K FACES AU SOMMET (INDICE RELATIF) C STRKSF : K SOMMET DE LA FACE(INDICE RELATIF) C STREOF : ENTITE OPPOSEE A FACE (INDICE RELATIF) C C AUTEUR : O. STAB C DATE : 03.95 C TESTS : O.STAB 03.95 C MODIFICATIONS : C AUTEUR, DATE, OBJET : O.STAB, 07.96, LE 3D (SMACRE,FAIDE,STRKFS) C AUTEUR, DATE, OBJET : O.STAB, 10.96, AJOUT DE NBPMAX DANS SMACRE C AUTEUR, DATE, OBJET : O.STAB, 04.97, BUG_15 (1D) + NETTOYAGE C AUTEUR, DATE, OBJET : O.STAB, 08.98, ISOLE DANS ST_GENERIC C C C ***************************************************************** C SUBROUTINE STINIT C ***************************************************************** C OBJET STINIT : INITIALISATION DES STRUCTURES DE DELOS C SINVOR FONCTION GENERIQUE DES STxINI C STINIT DOIT ETRE APPELE DE LE DEBUT DU PROGRAMME PRINCIPAL C ***************************************************************** CALL ST3INI END C SUBROUTINE STFASU(IDE,NBNE,ISOM,IFAC) C ************************************************************ C OBJET STFASU : FACE SUIVANTE SUR SOMMET(S) C STFASU FONCTION GENERIQUE DES SxFASU C EN ENTREE: C ...ISOM : LE SOMMET (2D) OU LES 2 SOMMETS DE L'ARETE (3D) C EN SORTIE: C IFAC : L'INDICE DE LA FACE SUIVANTE C ************************************************************ INTEGER IDE,NBNE,ISOM(*) INTEGER IFAC C GOTO( 10, 20, 30 ) IDE C --- CAS 0D ET 1D : 10 CONTINUE IFAC = -1 GOTO 9999 C --- CAS 2D : 20 CONTINUE CALL S2FASU(IDE,NBNE,ISOM,IFAC) GOTO 9999 C --- CAS 3D : 30 CONTINUE CALL S3FASU(IDE,NBNE,ISOM,IFAC) GOTO 9999 C 9999 END C C SUBROUTINE SINVOR(II, N, IDE, ITRNOE, ITRTRI ) C ************************************************************ C OBJET SINVOR : INVERSE L'ORIENTATION D'UN ELEMENT C SINVOR FONCTION GENERIQUE DES SxINVE C EN ENTREE: C II : (OBSOLET) C N : (2..4) NOMBRE DE NOEUDS DE L'ELEMENT C ARETE(2),TRIANGLE(3),QUADR(4),TETRA(4) C IDE : (1..3) DIMENSION DE L'ELEMENT C ARETE(1),TRIANGLE(2),TETRA(3) C ITRNOE: LES NOEUDS DU TRIANGLES C ITRTRI: LES VOISINS DU TRIANGLES C EN SORTIE: C ITRTRI : MIS A JOUR C ITRNOE : MIS A JOUR C CONDITION D'APPLICATION : ARETE, TRIANGLE, QUADRANGLE, TETRA C ************************************************************ INTEGER II, N, IDE, ITRNOE(N), ITRTRI(N) C INTEGER I, ITRNO1, ITRTR1 C GOTO(10,20,30) IDE GOTO 999 C --- CAS 1D --- 10 ITRNO1 = ITRNOE(1) ITRNOE(1) = ITRNOE(2) ITRNOE(2) = ITRNO1 ITRTR1 = ITRTRI(1) ITRTRI(1) = ITRTRI(2) ITRTRI(2) = ITRTR1 GOTO 999 C --- CAS 2D --- 20 ITRNO1 = ITRNOE(N) ITRNOE(N) = ITRNOE(2) ITRNOE(2) = ITRNO1 DO 25 I=1,(N/2) ITRTR1 = ITRTRI(I) ITRTRI(I) = ITRTRI(N-I+1) ITRTRI(N-I+1) = ITRTR1 25 CONTINUE GOTO 999 C --- CAS 3D --- 30 CALL S3INVE(N,IDE,ITRNOE,ITRTRI) GOTO 999 C 999 END C FUNCTION SFAIDE( IT1, IT2, N1, N2, IDE, I1, I2 ) C ***************************************************************** C OBJET SFAIDE : RECHERCHE LA FACE COMMUME A 2 ELEMENTS C SFAIDE FONCTION GENERIQUE DES SFACxD C RENVOI LES INDICES I1 ET I2 CORRESPONDANTS AUX FRONTIERES C COMMUNES DES ELEMETS IT1 ET IT2. C EN ENTREE: C IT1,IT2: LES ELEMENTS A TESTER C N1 : (2..4) NOMBRE DE NOEUDS DE IT1 C N2 : (2..4) NOMBRE DE NOEUDS DE IT2 C IDE : (1..3) DIMENSION DES ELEMENTS C EN SORTIE: C I1,I2 : INDICES DES FRONTIERES COMMUNES C SFAIDE : 0 SI AUCUNE ARETE COMMUNE C -1 SI L'ARETE I1 ET L'ARETE I2 SONT PARCOURUS DANS LE MEME C SENS POUR IT1 ET IT2 C 1 SI " " " " " " DANS LE SENS C INVERSE C CONDITION D'APPLICATION : ARETE, TRIANGLE, QUADRANGLE, TETRA C REMARQUE : N'UTILISE PAS LA STRUCTURE DE DONNEES MAILLAGE C N'EXPLOITE AUCUNE HYPOTHESE SUR IT1 ET IT2 C ***************************************************************** INTEGER SFAIDE INTEGER IT1(N1), IT2(N2), N1,N2, IDE, I1, I2 C INTEGER I,J EXTERNAL SFAC3D INTEGER SFAC3D C IF( IDE.EQ.2 )THEN C ----------------------- C CAS DES TRIANGLES OU DES QUADRANGLES C ON REALISE N1*N2*2 COMPARAISONS (X,Y) AVEC (A,B) ET (B,A) C ------------------------ DO 10 I=1,N1 DO 20 J=1,N2 IF ( (IT1(I) .EQ. IT2(J)) .AND. > (IT1(MOD(I,N1)+1) .EQ. IT2(MOD(J,N2)+1)) ) THEN I1 = I I2 = J SFAIDE = -1 GOTO 999 ENDIF IF( (IT1(I) .EQ. IT2(MOD(J,N2)+1)) .AND. > (IT1(MOD(I,N1)+1) .EQ. IT2(J)) ) THEN I1 = I I2 = J SFAIDE = 1 GOTO 999 ENDIF 20 CONTINUE 10 CONTINUE ELSE IF( IDE.EQ.1)THEN C ------------------------ C CAS DES ARETES : ON REALISE 4 COMPARAISONS (N1=N2=2) C ------------------------ DO 30 I=1,N1 DO 40 J=1,N2 IF (IT1(I) .EQ. IT2(J)) THEN I1 = I I2 = J IF( I.EQ.J )THEN SFAIDE = -1 ELSE SFAIDE = 1 ENDIF GOTO 999 ENDIF 40 CONTINUE 30 CONTINUE ELSE IF( IDE .EQ. 3 )THEN C ---------------------------- C CAS DES TETRAEDRES : ON REALISE 4*4*6 = 96 COMPARAISONS C ---------------------------- SFAIDE = SFAC3D( IT1, IT2, N1, N2, IDE, I1, I2 ) GOTO 999 ENDIF ENDIF ENDIF SFAIDE = 0 999 END C FUNCTION STRNBC(N,IDE) C ************************************************************* C OBJET STRNBC : NOMBRE DE FACES D'UN ELEMENT DE N NOEUDS C STRNBC FONCTION GENERIQUE DES SxNBCO C C ************************************************************* INTEGER STRNBC INTEGER N,IDE C INTEGER S3NBCO EXTERNAL S3NBCO C IF( IDE .EQ. 3 )THEN STRNBC = S3NBCO(N,IDE) ELSE STRNBC = N ENDIF END C FUNCTION STRKFS(IDE,I,N,IFAC) C ************************************************************ C OBJET STRKFS : INDICES DES FACES INCIDENTES AU SOMMET I C STRKFS FONCTION GENERIQUE DES SxSOFA C EN ENTREE: C I : L'INDICE DU SOMMET DE L'ELEMENT C N : (4) NOMBRE DE NOEUD DE L'ELEMENT C TETRA(4),PYRAM(5),PRISME(6),HEXA(8) C EN SORTIE: C IFAC : INDICE DES FACES INCIDENTES AU NOEUD C CONDITION D'APPLICATION : TETRAEDRE SEULEMENT C ************************************************************ INTEGER STRKFS INTEGER IDE, I, N, IFAC(*) C INTEGER S3SOFA EXTERNAL S3SOFA C GOTO (10,20,30 ) IDE C ---- CAS 1D -------- C LA FACE DE L'ELEMENT EST LE SOMMET LUI MEME 10 IFAC(1) = I STRKFS = 1 GOTO 999 C ---- CAS 2D -------- 20 IF(I.EQ.1)THEN IFAC(1) = N ELSE IFAC(1) = I-1 ENDIF IFAC(2) = I STRKFS = 2 GOTO 999 C ---- CAS 3D -------- 30 STRKFS = S3SOFA(IDE,I,N,IFAC) GOTO 999 C 999 END C FUNCTION STRKSF(IDE,N,INDIC,IFAC) C ************************************************************ C OBJET STRKSF : INDICES DES SOMMETS DE LA FACE I (SENS DIRECT) C STRKSF FONCTION GENERIQUE DES SxFASO C EN ENTREE: C INDIC : L'INDICE DE LA FACE DE L'ELEMENT C N : (4) NOMBRE DE NOEUDS DE L'ELEMENT C TETRA(4),PYRAM(5),PRISME(6),HEXA(8) C EN SORTIE: C IFAC : INDICE DES SOMMETS DE LA FACE C CONDITION D'APPLICATION : TETRAEDRE SEULEMENT C ************************************************************ INTEGER STRKSF INTEGER IDE, INDIC, N, IFAC(*) C INTEGER NBNF,K INTEGER S3FASO EXTERNAL S3FASO C IF( (IDE.EQ.2) .OR. (IDE.EQ.1) )THEN C ------------------------------------- C --- CAS 1D, 2D ---------------------- C --- NBR DE NOEUDS = NBRE DE COTES --- C ------------------------------------- DO 30 K=1,IDE IFAC(K) = MOD(INDIC+K-2,N)+1 30 CONTINUE STRKSF = IDE ELSE IF( IDE .EQ. 3 )THEN C ---------------------------------------------------- C --- CAS 3D : NOMBRE DE COTES REELS DE L'ELEMENTS --- C --- NOMBRE DE NOEUDS DE LA FACE J --- C ---------------------------------------------------- NBNF = S3FASO(IDE,N,INDIC,IFAC) STRKSF = NBNF ELSE STRKSF = 0 ENDIF ENDIF END C FUNCTION STREOF(IDE,N,IFE) C ************************************************************ C OBJET STREOF : INDICE DE L'ENTITE OPPOSEE A FACE IFE C STREOF FONCTION GENERIQUE DES SxOPFA C EN ENTREE: C IFE : L'INDICE DE LA FACE DE L'ELEMENT C N : (4) NOMBRE DE NOEUD DE L'ELEMENT C TETRA(4),PYRAM(5),PRISME(6),HEXA(8) C EN SORTIE: C POUR LES TETRAEDRES ET TRIANGLE : INDICE DU NOEUD OPPOSE C POUR LES QUADRANGLES : ARETE OPPOSEE C CONDITION D'APPLICATION : TETRAEDRE ET TRIANGLE SEULEMENT C ************************************************************ INTEGER STREOF INTEGER IDE, N, IFE C INTEGER S3OPFA EXTERNAL S3OPFA C IF( IDE .EQ. 3 )THEN STREOF = S3OPFA(IDE,N,IFE) GOTO 999 ENDIF IF(IDE.EQ.1)THEN STREOF = MOD(IFE,N)+1 GOTO 999 ENDIF IF(IDE.EQ.2)THEN C --- TRI OU QUAD --- STREOF = MOD(IFE+1,N)+1 GOTO 999 ENDIF STREOF = 0 999 END C ***************************************************************** C MODULE : ST (STRUCTURE DES DONNEES) C FICHIER : ST_1STRUCT.F C OBJET : FONCTIONS PRATIQUES POUR LA CREATION DE MAILLAGES C C FONCT. : C SMAOCR : CREER LA STRUCTURE DE DONNEE MAILLAGE ORIENTEE C (CAS DE PLUSIEURS COMPOSANTES CONNEXES) C SFRCRE : CREER LE MAILLAGE FRONTIERE D'UN ENSEMBLE DE C MAILLES C C AUTEUR : O. STAB C DATE : 03.95 C MODIFICATIONS : C AUTEUR, DATE, OBJET : O.STAB, 19.01.99 BUG APPEL SINVOR C C C ***************************************************************** C C SUBROUTINE SMAOCR(IDE,ITRI,NBE,COORD,NCOORD,IDIMC, > ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,NOEMAX, > ITVL,NBTRAV,NCC,IERR) C ***************************************************************** C OBJET : CREER LA STRUCTURE DE DONNEE MAILLAGE ORIENTEE C (CAS DE PLUSIEURS COMPOSANTES CONNEXES) C ITRI -> ITRNOE, ITRTRI, NOETRI C EN ENTREE: C IDE : (1..3) DIMENSION DES ELEMENTS C NBE : NOMBRE D'ELEMENTS DU MAILLAGE C ITRI : ITRI(I,J) EST LE NOEUD J DE L'ELEMENT I C NBNMAX : (2..8) NOMBRE DE NOEUDS MAXIMUM DES ELEMENTS C NBCMAX : (2..6) NOMBRE DE COTES MAXIMUM DES ELEMENTS C NOEMAX: TAILLE DU TABLEAU NOETRI C EN SORTIE: C ITRNOE: ITRNOE(I,J) EST LE NOEUD J DU TRIANGLE I C PEUT ETRE LE MEME TABLEAU QUE ITRI C ITRTRI: ITRTRI(I,J) EST L'ELEMENT INCIDENT A L'ELEMENT I SUR C LE COTE J C NOETRI : NOETRI(I) EST UN DES ELEMENTS CONTENANT LE NOEUD I C AU MIN = (NBCMAX+1)*NBE C AU MAX = MAX((NBCMAX+1)*NBE , C (NBR MAX D'ELEMENTS EN 1 NOEUD + 1) * C (NUMERO MAXI DU NOEUD DANS ITRI)) C => O(N) C IERR : CODE D'ERREUR 0 => OK C -2 => LE TABLEAU ITVL EST TROP PETIT C -NB => TABLEAU NOETRI TROP PETIT TAILLE SOUHAITE = NB C CONDITION D'APPLICATION : ARETE, TRIANGLE, QUADRANGLE, TETRA C ***************************************************************** INTEGER IDE,ITRI(*),NBE REAL COORD(*) INTEGER NCOORD,IDIMC,ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX INTEGER NOETRI(*), NOEMAX, ITVL(*), NBTRAV INTEGER NCC,IERR C INTEGER STRNBN, GORIEN EXTERNAL STRNBN, GORIEN INTEGER ITRAM,ITRAP,N,INDC,I,K,NBTRIP(100),IND,IEC REAL ZERO C ZERO = 0.0 CALL SMACRE(IDE,ITRI,NBE,NCOORD,ITRNOE,NBNMAX,ITRTRI,NBCMAX, > NOETRI,NOEMAX,ITVL,NBTRAV,IERR) C IF( IERR.LT.0 )THEN CALL DSERRE(1,IERR,'SMAOCR ',' APPEL SMACRE ') GO TO 999 ENDIF ITRAM = NBTRAV - NBE CALL SORIEN(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NBE, > ITVL,ITRAM,ITVL(ITRAM),NCC,IERR) IF(( IERR.LT.0 ).OR.( NCC.LE.0 ))THEN CALL DSERRE(1,IERR,'SMAOCR ',' APPEL SORIEN ') GO TO 999 ENDIF IF( IDE.LT.IDIMC )GO TO 999 C C --- ORIENTATION GEOMETRIQUE IDENTIQUE POUR CHAQUE CC C N'A DE SENS QUE SI LA DIMENSION DES ELEMENTS EST C IDENTIQUE A LA DIMENSION DE L'ESPACE C IF( NCC.EQ.1 )THEN C C --- UNE SEULE COMPOSANTE CONNEXE ----------------- C N = STRNBN(1,ITRNOE,NBNMAX) C IF( GORIEN(ITRNOE(1),N,COORD,IDIMC,ZERO).EQ.-1)THEN C O.STAB 12.97 AJOUT DE IDE DANS LES PARAMETRES DE GORIEN IF( GORIEN(ITRNOE(1),N,IDE,COORD,IDIMC,ZERO).EQ.-1)THEN DO 30 I=1,NBE N = STRNBN(I,ITRNOE,NBNMAX) C CALL SINVOR(N,IDE,ITRNOE((I-1)*NBNMAX+1), C BUG 19.01.99 O.STAB : PREMIER PARAMETRE (OUBLIE) INUTILISE CALL SINVOR(1,N,IDE,ITRNOE((I-1)*NBNMAX+1), > ITRTRI((I-1)*NBCMAX+1)) 30 CONTINUE ENDIF ELSE C C --- PLUSIEURS COMPOSANTES CONNEXES --------------- C ITRAP = NBTRAV - NBE ITRAM = ITRAP - NBE IND = 1 C C BUG3 O.STAB 03.08.95 NOMBRE DE PARAMETRES INCORRECT C CALL TMAPAR(IDE,ITRTRI,NBCMAX,IND,NBE, > ITVL,ITVL(ITRAM),ITRAM, > ITVL(ITRAP),NBTRIP,NCC,100,IERR) IF( IERR.LT.0 )THEN CALL DSERRE(1,IERR,'SMAOCR ',' APPEL TMAPAR ') GO TO 999 ENDIF INDC = 1 DO 50 I=1,NCC N = STRNBN(ITVL(ITRAP+INDC),ITRNOE,NBNMAX) C IF( GORIEN(ITRNOE(INDC),N,COORD,IDIMC,ZERO).EQ.-1)THEN C O.STAB 12.97 AJOUT DE IDE DANS LES PARAMETRES DE GORIEN IF( GORIEN(ITRNOE(INDC),N,IDE,COORD,IDIMC,ZERO).EQ.-1)THEN DO 40 K=0,(NBTRIP(I)-1) IEC = ITVL(ITRAP+INDC+K) N = STRNBN(IEC,ITRNOE,NBNMAX) C C BUG4 O.STAB 15.09.95 : NUMERO RELATIF DU COTE (SINVOR) C C CALL SINVOR(ITVL(ITRAP+INDC+K),N,IDE,ITRNOE, C > ITRTRI) C REMPLACER PAR : C CALL SINVOR(1,N,IDE,ITRNOE((IEC-1)*NBNMAX+1), > ITRTRI((IEC-1)*NBCMAX+1)) 40 CONTINUE ENDIF 50 CONTINUE ENDIF 999 END C C SUBROUTINE SFRCRE(IDE,IFR,NBIFR,ITRNOE,NBNMAX, > ITVL,NTRMAX, > LTRNOE,NNFMAX,LTRTRI,NCFMAX,NBF, > LNOETR,NBFNOE,NCC,IERR) C ***************************************************************** C OBJET : CREER LE MAILLAGE FRONTIERE D'UN ENSEMBLE DE MAILLES C C EN ENTREE: C IFR : IFR((I-1)*2+1) DONNE LE NUMERO DU IEME ELEMENT QUI A C UNE FACE SUR LA FRONTIERE C IFR((I-1)*2+2) DONNE LE NUMERO RELATIF DE LA FACE DU C IEME ELEMENT C NBIFR : NOMBRE D'ELEMENT DE LA FRONTIERE C C IDE : (1..3) DIMENSION DES ELEMENTS C NBNMAX : (2..8) NOMBRE DE NOEUDS MAXIMUM DES ELEMENTS C ITRNOE: ITRNOE(I,J) EST LE NOEUD J DE L'ELEMENT I C ITVL: TABLEAU DE TRAVAIL C NTRMAX: TAILLE DU TABLEAU DE TRAVAIL C SI IFR FORME 1 SEULE COMPOSANTE CONNEXE C AU MINIMUM = 2*((NBIFR*(NBCMAX-2))+2*NBCMAX) C 2D TRIANGLES = 2 * NBIFR + 12 C QUAD OU TETRA = 4 * NBIFR + 16 C AU MAX = (NBR MAX D'ELEMENTS EN 1 NOEUD + 1) * C NUMERO MAXI DU NOEUD DANS IFR C C NNFMAX : NOMBRE MAXIMUM DE NOEUD SUR UNE FACE DE LA FRONTIERE C NCFMAX : NOMBRE MAXIMUM DE COTE D'UNE FACE DE LA FRONTIERE C NBFNOE : TAILLE DU TABLEAU LNOETR C SI NBFNOE = 0 LNOETR NE SERA PAS REMPLI C C EN SORTIE: LE MAILLAGE DE LA FRONTIERE ET SES CARACTERISTIQUES C LTRNOE: C LTRTRI: C LNOETR: C NBF : NOMBRE DE FACES DE LA FRONTIERE C NCC : NOMBRE DE COMPOSANTES CONNEXES C IERR : CODE D'ERREUR C 0 SI OK C -1 SI LES DONNEES SONT ERRONEES C -2 SI ITVL TROP PETIT C C NIVEAU : INTERFACE UTILISATEUR C ***************************************************************** INTEGER IDE,IFR(*),NBIFR,ITRNOE(*),NBNMAX INTEGER ITVL(*),NTRMAX INTEGER LTRNOE(*),NNFMAX,LTRTRI(*),NCFMAX,NBF INTEGER LNOETR(*),NBFNOE,NCC,IERR C INTEGER I,J,IDEF INTEGER ITRAV,ITRAM,NBTRAV C C NOEUDS DE LA FRONTIERE C ---------------------- C IF( (NCFMAX * NBIFR).GT.NTRMAX )THEN IERR = -2 GO TO 999 ENDIF C DO 10 I=1,NBIFR CALL TNOFRT(IDE,ITRNOE,NBNMAX,IFR((I-1)*2+1), > IFR((I-1)*2+2),ITVL((I-1)*NCFMAX+1)) 10 CONTINUE NBF = NBIFR C PRINT *,' FRONTIERE ' C PRINT *,' ',((ITVL((I-1)*NCFMAX+J),J=1,NCFMAX),I=1,NBF) C C CONSTRUCTION DU MAILLAGE FRONTIERE C ---------------------------------- IDEF = IDE - 1 C --- ALLOCATION DES TABLEAUX : ITRAV,ITRAM,ITRAP ---- C TOPOFRTM OCCUPE ITVL DE 1 - NBF*NCFMAX C ITRAM DOIT AVOIR LA TAILLE DE NBF C NBTRAV PEUT VARIER DE 0 A (NCFMAX + 1) * NBF C ------------------------------------------------- IF( NTRMAX .LT. (NBF * (NCFMAX+1)) )THEN IERR = -2 GO TO 999 ENDIF C ITRAV = (NBF * NCFMAX ) + 1 NBTRAV = NTRMAX - ( NBF * NCFMAX ) C IF( NBTRAV.LT. 0 )THEN IERR = -2 GO TO 999 ENDIF C CALL SMACRE(IDEF,ITVL,NBF,0,LTRNOE,NNFMAX, > LTRTRI,NCFMAX,LNOETR,NBFNOE, > ITVL(ITRAV),NBTRAV,IERR) C C PRINT *,' MAILLAGE FRONTIERE ' C PRINT *,' ',((LTRNOE((I-1)*NNFMAX+J),J=1,NNFMAX),I=1,NBF) C PRINT *,' ',((LTRTRI((I-1)*NCFMAX+J),J=1,NCFMAX),I=1,NBF) C IF( IERR .NE. 0 )THEN CALL DSERRE(1,IERR,'SFRCRE',' APPEL SMACRE ') GO TO 999 ENDIF C ITRAM = 1 ITRAV = NBF + 1 NBTRAV = NTRMAX - NBF CALL SORIEN(IDEF,LTRNOE,NNFMAX,LTRTRI,NCFMAX,NBF, > ITVL(ITRAV),NBTRAV,ITVL(ITRAM),NCC,IERR) IF( IERR .NE. 0 )THEN CALL DSERRE(1,IERR,'SFRCRE',' APPEL SORIEN ') GO TO 999 ENDIF C 999 END C C ***************************************************************** C MODULE : ST (STRUCTURE DES DONNEES) C FICHIER : ST_TOPOLOGIE.F C OBJET : FONCTIONS TOPOLOGIQUES SUR LE MAILLAGE C FONCT. : C TMAFRT : CALCULE LA FRONTIERE D'UN ENSEMBLE DE MAILLES C CONSECUTIVES DANS LE MAILLAGE C TNOFRT : RENVOI LES NOEUDS DE LA FRONTIERE D'UN ELEMENT C TNOFRM : CALCUL LES NOEUDS DE LA FRONTIERE D'UN ENSEMBLE C DE MAILLES CONSECUTIVES DANS LE MAILLAGE C TMA1CC : CALCUL DES ELEMENTS CONNEXE AVEC 1 ELEMENT DONNE C TMAPAR : PARTITIONNE UN MAILLAGE EN COMPOSANTES C CONNEXES ET MATERIAUX C AUTEUR : O. STAB C DATE : 03.95 C TESTS : O.STAB 03.95 C MODIFICATIONS : C AUTEUR, DATE, OBJET : C C C ***************************************************************** C C SUBROUTINE TMAFRT(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,IND,NBE, > IFAC,NBFAC,NFAMAX,IERR) C ************************************************************** C OBJET : C CALCULE LA FRONTIERE D'UN ENSEMBLE DE MAILLES CONSECUTIVES C DANS LE MAILLAGE C EN ENTREE: C IDE : (1..3) DIMENSION DES ELEMENTS C ITRNOE : LES NOEUDS DES ELEMENTS C NBNMAX : (2..8) NOMBRE DE NOEUDS MAXIMUM DES ELEMENTS C ITRTRI : LES VOISINS DES ELEMENTS C NBCMAX : (2..6) NOMBRE DE COTES MAXIMUM DES ELEMENTS C IND : INDICE DU PREMIER ELEMENT DE L'ENSEMBLE C NBE : NOMBRE D'ELEMENTS DE L'ENSEMBLE C NFAMAX : NOMBRE MAXIMUM D'ELEMENTS FRONTIERE C C EN SORTIE: C IFAC : LISTE DES FACES DE LA FRONTIERE C NUMERO D'ELEMENT,INDICE DE LA FACE POUR L'ELEMENT C L'INDICE EST POSITIF SI LA FRONTIERE EST REELLE C L'INDICE EST NEGATIF SI C'EST UNE FRONTIERE INTERIEURE C EN ABSOLU 0 < | INDICE | < NBCMAX+1 C NBFAC : NOMBRE D'ELEMENTS DE LA FRONTIERE C IERR : CODE D'ERREUR 0 => OK, -2 => NCFMAX TROP PETIT C CONDITION D'APPLICATION : MAILLAGE MIXTE 1D,2D ET C ET TETRAEDRES C ************************************************************ INTEGER IDE,ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX,IND,NBE INTEGER IFAC(*),NBFAC,NFAMAX,IERR C INTEGER I,J,INDF,NBRN,NBC EXTERNAL STRNBN,STRNBC INTEGER STRNBN,STRNBC C IERR = 0 NBFAC = 0 INDF = (NBE-IND)+1 DO 20 I=IND,INDF DO 10 J=1,NBCMAX IF(( ITRTRI((I-1)*NBCMAX+J) .LE. 0 ).OR. > ( ITRTRI((I-1)*NBCMAX+J) .GT. INDF ))THEN NBRN = STRNBN(I,ITRNOE,NBNMAX) NBC = STRNBC(NBRN,IDE) IF(NBC.LT.J)GO TO 20 NBFAC = NBFAC + 1 IF(NBFAC.GT.NFAMAX)THEN IERR = -2 GO TO 999 ENDIF IFAC((NBFAC-1)*2+1) = I IFAC((NBFAC-1)*2+2) = J C --- POUR LES FRONTIERES INTERIEURES --- IF(ITRTRI((I-1)*NBCMAX+J).LT.0) > IFAC((NBFAC-1)*2+2) = -J ENDIF 10 CONTINUE 20 CONTINUE 999 END C SUBROUTINE TNOFRT(IDE,ITRNOE,NBNMAX,IT,IFAC,IFR) C ************************************************************** C OBJET : C RENVOI LES NOEUDS DE LA FRONTIERE D'UN ELEMENT C EN ENTREE: C IDE : (1..3) DIMENSION DES ELEMENTS C ITRNOE: LES NOEUDS DES ELEMENTS C NBNMAX : (2..8) NOMBRE DE NOEUDS MAXIMUM DES ELEMENTS C IT : INDICE DE L'ELEMENT C IFAC : INDICE DE LA FACE C C NCFMAX: NOMBRE MAXIMUM DE SOMMETS DES ELEMENTS FRONTIERE C =IDE SAUF EN 3D POUR LES PRISMES,PYRAMIDES,HEXA C EN SORTIE: C IFR : LISTE DES NOEUDS DE LA FRONTIERE C IERR : CODE D'ERREUR 0 => OK, -2 => NCFMAX TROP PETIT C CONDITION D'APPLICATION : MAILLAGE MIXTE 1D,2D ET C ET TETRAEDRES C ************************************************************ INTEGER IDE,ITRNOE(*),NBNMAX,IT,IFAC,IFR(*),NBIFR C INTEGER K,NBRN,NBNF,INDNF(4) EXTERNAL STRKSF, STRNBN INTEGER STRKSF, STRNBN C INTEGER IT1 C IT1 = IT NBRN = STRNBN(IT1,ITRNOE,NBNMAX) NBNF = STRKSF(IDE,NBRN,ABS(IFAC),INDNF) DO 10 K=1,NBNF IFR(K) = ITRNOE((IT1-1)*NBNMAX+INDNF(K)) 10 CONTINUE NBIFR = NBNF 999 END C C SUBROUTINE TNOFRM(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,IND,NBE, > IFR,NBIFR,NFRMAX,NCFMAX,IERR) C ************************************************************** C OBJET : C CALCULE LES NOEUDS DE LA FRONTIERE D'UN ENSEMBLE DE MAILLES C CONSECUTIVES DANS LE MAILLAGE C EN ENTREE: C IDE : (1..3) DIMENSION DES ELEMENTS C ITRNOE: LES NOEUDS DES ELEMENTS C NBNMAX : (2..8) NOMBRE DE NOEUDS MAXIMUM DES ELEMENTS C ITRTRI: LES VOISINS DES ELEMENTS C NBCMAX : (2..6) NOMBRE DE COTES MAXIMUM DES ELEMENTS C IND : INDICE DU PREMIER ELEMENT DE L'ENSEMBLE C NBE : NOMBRE D'ELEMENTS DE L'ENSEMBLE C NCFMAX: NOMBRE MAXIMUM DE SOMMETS DES ELEMENTS FRONTIERE C =IDE SAUF EN 3D POUR LES PRISMES,PYRAMIDES,HEXA C EN SORTIE: C IFR : LISTE DES ELEMENTS DE LA FRONTIERE C NBIFR : NOMBRE D'ELEMENTS DE LA FRONTIERE C IERR : CODE D'ERREUR 0 => OK, -2 => NCFMAX TROP PETIT C CONDITION D'APPLICATION : MAILLAGE MIXTE 1D,2D ET C ET TETRAEDRES C ************************************************************ INTEGER IDE,ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX,IND,NBE INTEGER IFR(*),NBIFR,NFRMAX,NCFMAX,IERR C INTEGER I,J,K,INDF,NBRN, NBNF,NBC,INDNF(4) EXTERNAL STRNBN,STRNBC,STRKSF INTEGER STRNBN,STRNBC,STRKSF C IERR = 0 IF((IDE.LT. 3).AND.(IDE .GT. NCFMAX))THEN IERR = -2 GO TO 999 ENDIF C NBIFR = 0 INDF = (NBE-IND)+1 DO 30 I=IND,INDF DO 20 J=1,NBCMAX IF(( ITRTRI((I-1)*NBCMAX+J) .LE. 0 ).OR. > ( ITRTRI((I-1)*NBCMAX+J) .GT. INDF ))THEN NBRN = STRNBN(I,ITRNOE,NBNMAX) NBC = STRNBC(NBRN,IDE) IF(NBC.LT.J)GO TO 30 NBIFR = NBIFR + 1 IF(NBIFR.GT.NFRMAX)THEN IERR = -2 GO TO 999 ENDIF C --- RECOPIE DES NOEUDS --- NBNF = STRKSF(IDE,NBRN,J,INDNF) IF( NBNF .GT. NCFMAX )THEN IERR = -2 GO TO 999 ENDIF DO 10 K=1,NBNF IFR((NBIFR-1)*NCFMAX+K) = > ITRNOE((I-1)*NBNMAX+INDNF(K)) 10 CONTINUE ENDIF 20 CONTINUE 30 CONTINUE 999 END C C C SUBROUTINE TMA1CC(IDE,ITRTRI,NBCMAX,IND,NBE, > IT,ITVL,ITRAMA,NBITL,ICON,NBICON,IERR) C ************************************************************** C OBJET : C CALCUL DES ELEMENTS APPARTENANT A UN ENSEMBLE C DE MAILLES CONSECUTIVES ET CONNEXE AVEC 1 ELEMENT DONNE C EN ENTREE: C IDE : (1..3) DIMENSION DES ELEMENTS C ITRTRI: LES VOISINS DES ELEMENTS C NBCMAX : (2..6) NOMBRE DE COTES MAXIMUM DES ELEMENTS C IND : INDICE DU PREMIER ELEMENT DE L'ENSEMBLE C NBE : NOMBRE D'ELEMENTS DE L'ENSEMBLE C IT : L'ELEMENT DE DEPART C ITVL,NBITL : TABLEAU DE TRAVAIL NBITL < N*NBE C ITRAMA : " " " " DE TAILLE = NBE C EN SORTIE: C ICON : LISTE DES ELEMENTS CONNEXES AVEC IT C NBICON : NBRE D'ELEMENTS DE ICON C IERR : CODE D'ERREUR 0 => OK, -2 => ITVL TROP PETIT C CONDITION D'APPLICATION : MAILLAGE MIXTE 1D,2D ET C ET TETRAEDRES C ATTENTION : ITRAMA DOIT ETRE INITIALISE C NORMALEMENT ITRAMA(0..NBE) = 0 C SI ITRAMA(I)=1 ON CONSIDERE QUE L'ELEMENT I EST BLOQUANT C IT EST MIS DANS LA COMPOSANTE CONNEXE C ************************************************************ INTEGER IDE,ITRTRI(*),NBCMAX,IND,NBE INTEGER IT,ITRAMA(*),ITVL(*),NBITL,ICON(*),NBICON,IERR C INTEGER I,J, NBTRA, ITT C ITVL(1) = IT ITRAMA(IT) = 1 NBTRA = 1 IERR = 0 C C ON BOUCLE TANTQUE ITVL N'EST PAS VIDE C ---------------------------------------- 310 J = ITVL(NBTRA) NBTRA = NBTRA-1 NBICON = NBICON+1 ICON(NBICON) = J C ON MET LES VOISINS A TRAITER DANS ITVL C ------------------------------------------ DO 350 I=1,NBCMAX ITT = ITRTRI(((J-1)*NBCMAX)+I) C IF((ITT.GT.IND).AND.(ITRAMA(ITT).NE.1))THEN C BUG2 O.STAB 03.08.95 IF((ITT.GE.IND).AND.(ITRAMA(ITT).EQ.0))THEN NBTRA = NBTRA + 1 IF( NBTRA .GT. NBITL )THEN IERR = -2 GO TO 999 ENDIF C ITVL(NBTRA) = ITT ITRAMA(ITT) = 1 ENDIF 350 CONTINUE IF( NBTRA .NE. 0 )GO TO 310 999 END C C C SUBROUTINE TMAPAR(IDE,ITRTRI,NBCMAX,IND,NBE, > ITVL,ITRAMA,NBIT1, > ITRPAR,NBTRIP,NBPART,NPARMX,IERR) C ************************************************************** C OBJET : PARTITIONNE UN MAILLAGE EN FONCTION DES COMPOSANTES C CONNEXES ET DES MATERIAUX C EN ENTREE: C IDE : (1..3) DIMENSION DES ELEMENTS C ITRTRI: LES VOISINS DES ELEMENTS C NBCMAX : (2..6) NOMBRE DE COTES MAXIMUM DES ELEMENTS C IND : INDICE DU PREMIER ELEMENT DE L'ENSEMBLE C NBE : NOMBRE D'ELEMENTS DE L'ENSEMBLE C ITVL,NBITL : TABLEAU DE TRAVAIL NBITL < NBCMAX*NBE C ITRAMA : " " " " DE TAILLE = NBE C EN SORTIE : C NBPAR : NOMBRE DE MATERIAUX C NBTRIP : NBTRIP(I) DONNE LE NOMBRE DE TRIANGLE DU MATERIAU I C ITRPAR: TABLEAU DES TRIANGLES TRIES EN FONCTION DU MATERIAU C LES TRIANGLES DU MATERIAU I SONT ENTRE : C ITRPAR(NBTRIP(I-1)+1) ET ITRPAR(NBTRIP(I)) C IERR : CODE D'ERREUR 0 => OK, -2 => ITVL TROP PETIT C *************************************************************** INTEGER IDE,ITRTRI(*),NBCMAX,IND,NBE INTEGER ITRPAR(*), NBTRIP(*),NBPART,NPARMX,IERR INTEGER ITRAMA(*), ITVL(*), NBIT1 C INTEGER I, IT, INDICE, NBTT, INDF C C INITIALISATION C -------------- NBPART = 0 IERR = 0 NBTT = 0 INDF = (NBE-IND)+1 DO 10 I=IND,INDF ITRAMA(I) = 0 10 CONTINUE NBTT=0 IT = IND 20 IF( NBTT .EQ. NBE )GOTO 888 30 IF( ITRAMA(IT) .NE. 0 )THEN IT=IT+1 IF( IT .GT. INDF )GO TO 999 GO TO 30 ENDIF NBPART = NBPART+1 IF( NBPART.GT.NPARMX)THEN IERR = -2 GO TO 999 ENDIF INDICE = NBTT+1 NBTRIP(NBPART) = 0 CALL TMA1CC(IDE,ITRTRI,NBCMAX,IND,NBE,IT,ITVL,ITRAMA, > NBIT1,ITRPAR(INDICE),NBTRIP(NBPART),IERR) IF( IERR .NE. 0 )GO TO 999 NBTT = NBTT + NBTRIP(NBPART) GO TO 20 C --- POUR LE DEBUG --- 888 DO 890 I=IND,INDF IF( ITRAMA(I).EQ.0 )THEN IERR = -1 ENDIF 890 CONTINUE 999 END C ***************************************************************** C MODULE : ST (MODULE STRUCTURE) C FICHIER : ST_POLYGON.F C OBJET : OPERATIONS ELEMENTAIRES SUR LES POLYGONES SIMPLEMENT C CONNEXES C C FONCT. : C ARTOPL: EXTRAIT UN POLYGONE FERME D'UN MAILLAGE D'ARETES C SPLIPL: DECOUPE (SPLIT) UN POLYGONE PAR UNE ARETE C C AUTEUR : O. STAB C DATE : 03.95 C MODIFICATIONS : C AUTEUR, DATE, OBJET : STAB, 12.97, COMMENTAIRES C C C ***************************************************************** C C SUBROUTINE ARTOPL(IARNOE,NBNMAX,IARAR,NBCMAX,IPOLY,NBPP) C ***************************************************************** C OBJET ARTOPL : EXTRAIT UN POLYGONE FERME D'UN MAILLAGE D'ARETES C C EN ENTREE : C IARNOE,NBNMAX: NOEUDS DES ARETES C IARNOE((I-1)*NBNMAX+1) NOEUD ORIGINE DE L'ARETE I C IARNOE((I-1)*NBNMAX+2) NOEUD EXTREMITE DE L'ARETE I C IARAR,NBCMAX: ARETE ADJACENTES C IARAR((I-1)*NBNMAX+1) ARETE PRECEDENTE DE I C IARNOE((I-1)*NBNMAX+2) ARETE SUIVANTE DE I C C EN SORTIE : C IPOLY : TABLEAU DES NUMEROS DES NOEUDS C NBPP : NOMBRE DE POINTS DU POLYGONE. C C ***************************************************************** INTEGER IARNOE(*),NBNMAX,IARAR(*),NBCMAX,IPOLY(*),NBPP C INTEGER IDEBUT,ISUIV C IDEBUT = 1 NBPP = 1 IPOLY(1) = IARNOE(1) ISUIV = IARAR(2) 10 IF( ISUIV .EQ. IDEBUT )GO TO 999 NBPP = NBPP+1 IPOLY(NBPP) = IARNOE((ISUIV-1)*NBNMAX+1) ISUIV = IARAR((ISUIV-1)*NBCMAX+2) GO TO 10 999 END C SUBROUTINE SPLIPL(IPOLY,NBPP,NN,IPOLY1,NBPP1,IPOLY2,NBPP2,IERR) C ***************************************************************** C OBJET SPLIPL : DECOUPE (SPLIT) UN POLYGONE PAR UNE ARETE C C EN ENTREE: C IPOLY,NBPP: POLYGONE A DECOUPER C NN : NOEUDS DE L'ARETE DE COUPE (NN(1),NN(2)) C C EN SORTIE: C IPOLY1 : CONTIENT L'ARETE NN(1) VERS NN(2) C EN IPOLY1(NBPP1)IPOLY(1) C IPOLY2 : CONTIENT L'ARETE NN(2) VERS NN(1) C EN IPOLY2(NBPP2)IPOLY(1) C IERR : 0 SI OK, -1 SI NN(1) OU NN(2) NE SONT PAS CORRECTS C C.A.D. SI NN(1) = NN(2) OU SI NN(1) OU NN(2) C NE SONT PAS DANS IPOLY C C ***************************************************************** INTEGER IPOLY(*),NBPP,NN(*),IPOLY1(*),NBPP1,IPOLY2(*),NBPP2,IERR C INTEGER INM1,INM2,I,I1,I2 C IERR = -1 IF(NN(1).EQ.NN(2))THEN CALL DSERRE(1,IERR,'SPLIPL',' ARETE: ORIGINE=EXTREMITE') GO TO 999 ENDIF C --- RECHERCHE NN(2) --- INM1 = 0 INM2 = 0 DO 10 I=1,NBPP IF( IPOLY(I).EQ. NN(1) )INM1 = I IF( IPOLY(I).EQ. NN(2) )INM2 = I 10 CONTINUE IF(INM1.EQ.0)THEN CALL DSERRE(1,IERR,'SPLIPL',' ORIGINE HORS POLYGONE') GO TO 999 ENDIF IF(INM2.EQ.0)THEN CALL DSERRE(1,IERR,'SPLIPL',' EXTREMITE HORS POLYGONE') GO TO 999 ENDIF C --- POLY1 DE : INM2 -> INM1 --- IF( INM1.LT.INM2 )THEN NBPP2 = INM2 - INM1 + 1 NBPP1 = NBPP - NBPP2 + 2 ELSE NBPP1 = INM1 - INM2 + 1 NBPP2 = NBPP - NBPP1 + 2 ENDIF I1 = INM2 DO 20 I=1,NBPP1 IPOLY1(I) = IPOLY(I1) I1 = MOD(I1,NBPP)+1 20 CONTINUE I2 = INM1 DO 30 I=1,NBPP2 IPOLY2(I) = IPOLY(I2) I2 = MOD(I2,NBPP)+1 30 CONTINUE IERR = 0 999 END C C ***************************************************************** C MODULE : C FICHIER : ST_DOMAIN.F C OBJET : GESTION DES MAILLAGES LINEIQUES ET DES GEOMETRIES DE DOMAINES C FONCT. : C C OBJET DFR2FR : TRANSFORME UN MAILLAGE LINEIQUE EN FRONTIERE DE DOMAINE C DFR2FR ANCIENNEMENT DANS ESLIFR ! C OBJET DFR2RG : AFFECTE LES REGIONS A PARTIR DE LA FRONTIERE C DFR2RG ANCIENNEMENT DANS LES PROGRAMMES C OBJET DRG2FR : EXTRAIT LA FRONTIERE (GEOMETRIQUE) D'UN MAILLAGE C DRG2FR ANCIENNEMENT TMAFRM ! C C LA FRONTIERE D'UN DOMAINE EST UN MAILLAGE POUR LEQUEL ON A C LES INFORMATION SUIVANTES : C + MATERIAU A GAUCHE, MATERIAU A DROITE DE CHAQUE ELEMENT FRONTIERE C + INDICES DES ELEMENTS REELS DE FRONTIERE. C (IFREEL, NFREEL : INTERVAL DES INDICES) C C ********************************************************************** C SUBROUTINE REFREG(IEL,TRIMAT,REFMAT,NMT,IMAT,IERR) C ************************************************************** C OBJET REFREG : DONNE LA REFERENCE DE REGION D'UN ELEMENT C C EN ENTREE: C IEL : NUMERO DE L'ELEMENT C TRIMAT : TABLEAU DES INTERVALS C REFMAT : TABLEAU DES REFERENCES C NMT : NOMBRE DE REGIONS C C EN SORTIE: C IMAT : REFERENCE DE LA REGION DE IEL C IERR : 0 SI TROUVE, -1 SI HORS INTERVAL C ************************************************************** INTEGER IEL,TRIMAT(*),REFMAT(*),NMT INTEGER IMAT,IERR C IF( IEL .LE. 0 )THEN IMAT = 0 IERR = -1 GOTO 9999 ENDIF C DO 10 IMAT=1,NMT IF( TRIMAT(IMAT).GE. IEL )GOTO 9999 10 CONTINUE C ---- ON A PAS TROUVE L'INTERVAL DES MATERIAUX ---- IMAT = 0 IERR = -1 9999 END C C SUBROUTINE DFR2FR(IDE1,ITRNO1,NBNMX1,NBE1, > ITRIR1,NR1MAX,IMTRF1,NMT1,INTIN1,NBINT1, > IMATGD,IFREEL,NFREEL,NMAT, > ITVL,NITMAX,IERR) C ********************************************************************** C OBJET DFR2FR : TRANSFORME UN MAILLAGE LINEIQUE EN FRONTIERE DE DOMAINE C EN ENTREE : C ITRIR1,NR1MAX : ITRIR1(I) = REGION DE L'ELEMENT I (SI NR1MAX > 0) C IMTRF1,NMT1 : IMTRF1(I) = REFERENCE DE LA IEME REGION (SI NMT1>0) C INTIN1,NBINT1 : INTIN1(I-1),INTIN1(I) = INDICE DU PREMIER ET DERNIER C ELEMENT DE REFERENCE IMTRF1(I) (SI NBINT1>0) C EN SORTIE : C LA MAILLAGE A ETE ORDONNE ! C IMATGD : IMATGD(I) MATERIAU GAUCHE ET DROIT DE L'ELEMENT I C IFREEL : INDICE DU PREMIER ELEMENT DE FRONTIERE (EXTERIEUR = REELLE) C NFREEL : NOMBRE D'ELEMENTS DE FRONTIERE (REELLE) C NMAT : NOMBRE DE MATERIAUX C C 3 TYPES DE FRONTIERES : C FRONTIERES REELLES (VIDE/PLEIN) C IMATGD() = (0,+I) OU (+I,0) C FRONTIERES INTER-MATERIAUX (MATI/MATJ) C IMATGD() = (+I,+J) C FRONTIERES GEOMETRIQUES (MATI/MATI) C IMATGD() = (+I,+I) C UN MATERIAU INCONNU = -1 C C CONVENTIONS POUR LE MAILLAGE : C LES ELEMENTS DE LA FRONTIERE REELLE (MAT > 0) C LES ELEMENTS DES FRONTIERES INTER-MATERIAUX (MAT < 0) C LES ELEMENTS IMPOSEES POUR LES RACCORDS (MAT = 0) C C ********************************************************************** INTEGER IDE1,ITRNO1(*),NBNMX1,NBE1 INTEGER ITRIR1(*),NR1MAX,IMTRF1(*),NMT1,INTIN1(*),NBINT1 INTEGER IMATGD(*),IFREEL,NFREEL,NMAT INTEGER ITVL(*),NITMAX,IERR C INTEGER MATG,MATD,NOEMX2,NBCMX2,NRGREF,ITRTRI,NOETRI INTEGER INTMAT,IREF,I,J,IDMAT,IFMAT,NMT2,IMAT INTEGER ITRAV,NITMX2 C IERR = 0 ITRAV = 1 NITMX2 = NITMAX IF((NMT1.EQ.0).AND.(NBE1.EQ.0))THEN NMAT = 0 IFREEL = 0 NFREEL = 0 GOTO 9999 ENDIF IF(NMT1.EQ.0)THEN C ---- ON POURRAIT ANALYSER ITRIR1 SI IL EST DONNE ! POUR L'INSTANT ERREUR IERR = -1 CALL DSERRE(1,IERR,'DFR2FR','PAS DE MATERIAU ?') GOTO 9999 ENDIF C NMT1 = 1 PAS BESOIN DE TRIER C NBINT1 = DEJA TRIE ! IF((NMT1.EQ.1).OR.(NBINT1.EQ.NMT1))GOTO 200 C ----------------------------------------- C --- 1.RENUMEROTATION : MATERIAUX CROISSANT --- C ----------------------------------------- NOEMX2 = 0 NBCMX2 = 0 NRGREF = 0 ITRTRI = 1 NOETRI = 1 INTMAT = ITRAV ITRAV = INTMAT + NMT1 NITMX2 = NITMAX - ITRAV + 1 IF(( NITMX2.LT.1 ).OR. > ((NMT1.GT.1).AND.(NITMX2.LT. MAX(NMT1,2*NBE1))))THEN IERR = -2 CALL DSERRE(1,IERR,'DFR2FR','PLACE POUR APPEL A RGCOMP') GOTO 9999 ENDIF CALL RGCOMP(IDE1,ITRNO1,NBNMX1, > ITVL(ITRTRI),NBCMX2,ITVL(NOETRI), > NOEMX2,NBE1,ITVL(ITRAV), C IMTREF EN ENTREE ET SORTIE : A VERIFIER ... > ITRIR1,IMTRF1,NMT1, > IMTRF1,ITVL(INTMAT),NRGREF,NMT1,IERR) C ----------------------------------------- C ---- 2. FRONTIERE = REFERENCE POSITIVE --- C ----------------------------------------- 200 CONTINUE C ---- UN SEUL MATERIAU --- IF(NMT1.LE.1)THEN IFREEL = 1 NFREEL = NBE1 GOTO 300 ENDIF C ---- ON A LES REFERENCES ---- DO 210 IREF=1,NMT1 IF( IMTRF1(IREF).GT.0 )GOTO 220 210 CONTINUE IERR = -1 CALL DSERRE(1,IERR,'DFR2FR','PAS DE FRONTIERE GEOMETRIQUE ! ') GOTO 9999 220 CONTINUE IFREEL = 1 IF( IREF.GT.1 )THEN C ---- ON A DONNE LES INTERVALS --- IF(NBINT1.EQ.NMT1)THEN IFREEL = INTIN1(IREF-1) ELSE C ---- ON A CALCULE LES INTERVALS --- IFREEL = ITVL(INTMAT+IREF-2) ENDIF ENDIF NFREEL = NBE1 - IFREEL + 1 C -------------------------------------------- C --- 3. RECONNAISSANCE DE LA GEOMETRIE --- C -------------------------------------------- 300 CONTINUE IDMAT = 1 DO 20 I=1,NMT1 IF(NBINT1.EQ.NMT1)THEN IFMAT = INTIN1(I) ELSE IFMAT = ITVL(INTMAT+I-1) ENDIF IF( IMTRF1(I) .LT.0 )THEN MATG = - IMTRF1(I) MATD = - 1 ELSE IF( IMTRF1(I) .EQ.0 )THEN MATG = -1 MATD = -1 ELSE MATG = IMTRF1(I) MATD = IMTRF1(I) ENDIF ENDIF DO 10 J=IDMAT,IFMAT IMATGD((J-1)*2+1) = MATG IMATGD((J-1)*2+2) = MATD 10 CONTINUE IDMAT = IFMAT+1 20 CONTINUE GOTO 500 C C --- UNE VARIANTE ???? DO 410 I=1,NBE1 C ---- FRONTIERE INTERNE ---- IF( ITRIR1(I).LT.0 )THEN MATG = - ITRIR1(I) MATD = - 1 ELSE C ---- ARETE IMPOSEE ---- IF( ITRIR1(I) .EQ.0 )THEN MATG = -1 MATD = -1 ELSE C ---- FRONTIERE GEOMETRIQUE ---- C (ON NE SAIT PAS DE QUEL COTE EST LE MAT) MATG = ITRIR1(I) MATD = ITRIR1(I) ENDIF ENDIF IMATGD((I-1)*2+1) = MATG IMATGD((I-1)*2+2) = MATD 410 CONTINUE C -------------------------------------------- C --- 5. CALCUL DU NOMBRE DE MATERIAU(X) ---- C -------------------------------------------- C --- ON NE PREND QUE LES VALEURS POSITIVES DISTINCTES --- 500 CONTINUE IMAT = ITRAV ITRAV = IMAT + NMT1 NITMX2 = NITMAX - ITRAV + 1 IF( NITMX2.LT.0 )THEN IERR = -2 CALL DSERRE(1,IERR,'DFR2FR','PLUS DE PLACE (1)') GOTO 9999 ENDIF NMT2 = 0 DO 530 I=1,NMT1 IF( IMTRF1(I).GT.0 )THEN NMT2 = NMT2 + 1 ITVL(IMAT+NMT2-1) = IMTRF1(I) ELSE IF( IMTRF1(I).LT.0 )THEN NMT2 = NMT2 + 1 ITVL(IMAT+NMT2-1) = -IMTRF1(I) ENDIF ENDIF 530 CONTINUE IF( NMT2.GT.1 )THEN IF( NITMX2.LT.NMT2 )THEN IERR = -2 CALL DSERRE(1,IERR,'DFR2FR','PLUS DE PLACE (2)') GOTO 9999 ENDIF CALL TBVTAB(ITVL(IMAT),NMT2,ITVL(ITRAV),ITVL(IMAT),NMAT, > NMT1,IERR) C PRINT *,'DFR2FR : MATERIAU = ',(ITVL(IMAT+I-1),I=1,NMAT) IF( IERR.NE.0 )THEN CALL DSERRE(1,IERR,'DFR2FR','APPEL TBVTAB') GOTO 9999 ENDIF ELSE NMAT = NMT2 ENDIF C 9999 END C SUBROUTINE DFR2RG(IDE1,ITRNO1,NBNMX1,NBE1,IMAT,NMT1, > IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,NOEMAX,NBE, > MAJNOE, > ITRIRG,NRGMAX,IMTREF,IMTMAX,INTMAT,INTMAX,NMT, > ITVL,NITMAX,IERR) C ********************************************************************** C OBJET DFR2RG : AFFECTE LES REGIONS A PARTIR DE LA FRONTIERE C EN ENTREE : C IDE1,ITRNO1,NBNMX1,,NBE1,IMAT : LA FRONTIERE C IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,NOEMAX,NBE : LE MAILLAGE C MAJNOE : NOETRI EST NECESSAIRE AU TRAITEMENT, EN REVANCHE C ON PEUT SOUHAITER LE METTRE A JOUR (1) OU PAS (0) C EN SORTIE : C ITRIRG,NRGMAX,IMTREF,NMT,INTMAT,NBINMX : LES REGIONS C LE MAILLAGE EST MODIFIE; LES ELEMENTS SONT TRIES DANS LE CAS C DE PLUSIEURS MATERIAUX C ********************************************************************** INTEGER IDE1,ITRNO1(*),NBNMX1,NBE1,IMAT(*),NMT1 INTEGER IDE,ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX,NOETRI(*),NOEMAX INTEGER NBE,MAJNOE INTEGER ITRIRG(*),NRGMAX,IMTREF(*),IMTMAX,INTMAT(*),INTMAX,NMT INTEGER ITVL(*) INTEGER NITMAX,IERR C C MATERIAU PAR DEFAUT : PARAMETER (DEFMAT = 1) INTEGER DEFMAT PARAMETER (DEFMAT = 1) INTEGER NMTMAX,PTRIRG,PMTREF,IMATCC,PNTMAT,NOEMX2,NRGREF INTEGER ITRAV,NITMX2,I C IERR = 0 ITRAV = 1 NITMX2 = NITMAX C ============================= C ---- 1. CAS MONO-MATERIAU SIMPLE ---- C ============================= IF(( NMT1.LE.1 ).OR.(NBE1.EQ.0))THEN C ---- CAS MONO-MATERIAU OU PAS D'ELEMENT DE FRONTIERE ---- NMT = 1 IF( NMT1.EQ.1 )THEN IF(IMTMAX.GE.1)IMTREF(1) = IMAT(1) ELSE IF(IMTMAX.GE.1)IMTREF(1) = DEFMAT ENDIF IF(INTMAX.GE.1)INTMAT(1) = NBE GOTO 9999 ENDIF C ---- CAS PLUSIEURS MATERIAUX POSSIBLE ---- C =============================== C ---- 2. IDENTIFICATION DES REGIONS ---- C =============================== C NMTMAX = NMT1 C REMPLACE PAR : O.STAB 29.07.99, ON AUTORISE 10 CC PAR MATERIAU NMTMAX = NMT1*10 IF( NRGMAX.LE.0 )THEN PTRIRG = ITRAV ITRAV = PTRIRG + NBE NITMX2 = NITMAX - ITRAV ELSE IF(NRGMAX.LT.NBE)THEN IERR = -2 CALL DSERRE(1,IERR,'DFR2RG','ITRIRG TROP PETIT') GOTO 9999 ENDIF ENDIF 210 CONTINUE C PMTREF = ITRAV IMATCC = PMTREF + NMTMAX ITRAV = NMTMAX + IMATCC NITMX2 = NITMAX - ITRAV C --- ON A BESOIN DE "ITRAV" SEULEMENT SI PLUSIEURS CC ------ IF(NITMX2.LE.(NBE+(2*NBE1)+4))THEN IERR = -2 CALL DSERRE(1,IERR,'DFR2RG',' POUR APPEL A RGRGNO') C CALL ESEINT(1,'TAILLE MANQUANTE ITVL :', C > (NITMX2-(NBE+(2*NBE1)+4)),1) GOTO 9999 ENDIF C IF( NRGMAX.GT. 0 )THEN CALL RGRGNO(ITRNO1,NBNMX1,NBE1,IMAT, > IDE,ITRNOE, > NBNMAX,ITRTRI,NBCMAX, > NOETRI,NBE,ITVL(ITRAV),NITMX2, > ITRIRG,ITVL(PMTREF),ITVL(IMATCC),NMT, > NMTMAX,IERR) ELSE CALL RGRGNO(ITRNO1,NBNMX1,NBE1,IMAT, > IDE,ITRNOE, > NBNMAX,ITRTRI,NBCMAX, > NOETRI,NBE,ITVL(ITRAV),NITMX2, > ITVL(PTRIRG),ITVL(PMTREF),ITVL(IMATCC),NMT, > NMTMAX,IERR) ENDIF C --- ON NE CONNAIT PAS LA REPARTITION EN COMPOSANTES CONNEXES --- C PRINT *,'NMT = ',NMT C PRINT *,'NMTMAX = ',NMTMAX C PRINT *,'REFERENCES = ',(ITVL(PMTREF+I-1),I=1,NMTMAX) C PRINT *,'COMPOSANTES = ',(ITVL(IMATCC+I-1),I=1,NMTMAX) IF((IERR .EQ. -2 ).AND.(NMT.GT.NMTMAX))THEN NMTMAX = NMT IERR = 0 ITRAV = PMTREF GOTO 210 ENDIF IF( IERR .NE. 0 )THEN CALL DSERRE(1,IERR,'DFR2RG',' APPEL RGRGNO ') CALL DSERRE(1,IERR,'DFR2RG',' AFFECTATION DES MATERIAUX') GO TO 9999 ENDIF ITRAV = IMATCC NITMX2 = NITMAX - ITRAV + 1 C C ================================================= C --- 3. RENUMEROTATION ELEMENTS : MATERIAUX CROISSANT --- C ================================================= IF( NMT.EQ.1 )THEN IF( INTMAX.GT.0 )INTMAT(1) = NBE IF( IMTMAX.GT.0 )IMTREF(1) = ITVL(PMTREF) GOTO 9999 ENDIF C PNTMAT = ITRAV ITRAV = NMTMAX + PNTMAT NOEMX2 = NOEMAX IF(MAJNOE.NE.1)NOEMX2 = 0 IF( NRGMAX.GT.0 )THEN CALL RGCOMP(IDE,ITRNOE,NBNMAX, > ITRTRI,NBCMAX,NOETRI, > NOEMX2,NBE,ITVL(ITRAV), > ITRIRG,ITVL(PMTREF),NMT, > ITVL(PMTREF),ITVL(PNTMAT),NRGREF,NMTMAX,IERR) ELSE CALL RGCOMP(IDE,ITRNOE,NBNMAX, > ITRTRI,NBCMAX,NOETRI, > NOEMX2,NBE,ITVL(ITRAV), > ITVL(PTRIRG),ITVL(PMTREF),NMT, > ITVL(PMTREF),ITVL(PNTMAT),NRGREF,NMTMAX,IERR) ENDIF IF( IERR .NE. 0 )THEN CALL DSERRE(1,IERR,'DFR2RG',' APPEL RGCOMP') GO TO 9999 ENDIF C C ======================= C --- 4. COPIE DES TABLEAUX --- C ======================= 400 CONTINUE IF( INTMAX.GT.0 )THEN IF( INTMAX.LT.NRGREF )THEN IERR = -2 CALL DSERRE(1,IERR,'DFR2RG','INTMAT TROP PETIT') GOTO 9999 ENDIF DO 410 I=1,NRGREF INTMAT(I) = ITVL(PNTMAT+I-1) 410 CONTINUE ENDIF C IF( IMTMAX.GT.0 )THEN IF( IMTMAX.LT.NRGREF )THEN IERR = -2 CALL DSERRE(1,IERR,'DFR2RG','IMTREF TROP PETIT') GOTO 9999 ENDIF DO 420 I=1,NRGREF IMTREF(I) = ITVL(PMTREF+I-1) 420 CONTINUE ENDIF C 9999 END C SUBROUTINE DRG2FR(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NBE, > TRIMAT,REFMAT,NMT, > ITVL,NITMAX, > INOEFR,INOMAX, > IRRGFR,IIRGFR,NMTFR,IREMAX, > NBEFR,NBNFR,IERR) C ************************************************************** C OBJET DRG2FR : EXTRAIT LA FRONTIERE (GEOMETRIQUE) D'UN MAILLAGE C (AVEC LEURS MATERIAUX) C EN ENTREE: C IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NBE : LE MAILLAGE C TRIMAT,REFMAT,NMT : LES REGIONS C C ITVL : TABLEAU DE TRAVAIL (ENTIER) C NITMAX : TAILLE DE ITVL (>= NMT+ NBEFR*2) C C INOEFR: TABLEAU A REMPLIR (ELEMENTS) (TAILLE = NBEFR*NBNFR) C INOMAX: TAILLE DU TABLEAU INOEFR C C IRRGFR : TABLEAU A REMPLIR (MATERIAUX) C IIRGFR : TABLEAU A REMPLIR (INTERVALS) C IREMAX : TAILLE DE IRRGFR ET IIRGFR (TAILLE >2*NMT) C C NBNFR : NOMBRE MAXIMUM DE SOMMETS DES ELEMENTS FRONTIERE C IL PEUT ETRE CONNU ET DONNE, SINON =0 ET IL SERA CALCULE C C EN SORTIE: C INOEFR : LISTE DES NOEUDS DES ELEMENTS DE LA FRONTIERE C IIRGFR : INTERVAL DES ELEMENTS C IRRGFR : REFERENCE DES MATERIAUX C IRRGFR(IIRGFR(IEL)) : NUMERO DE LA REGION INCIDENTE C A L'ELEMENT DE FRONTIERE IEL C POSITIF SI LA FRONTIERE EST EXTERNE C NEGATIF SI LA FRONTIERE EST INTERNE C -NUMERO DONNE ALORS LA REGION A GAUCHE C NBEFR : NOMBRE D'ELEMENTS DE LA FRONTIERE C NBNFR : NOMBRE MAXIMUM DE SOMMETS DES ELEMENTS FRONTIERE C =IDE SAUF EN 3D POUR LES PRISMES,PYRAMIDES,HEXA C IERR : CODE D'ERREUR 0 => OK, -2 => NCFMAX TROP PETIT C C CONDITION D'APPLICATION : MAILLAGE MIXTE 1D,2D ET C ET TETRAEDRES C ************************************************************ INTEGER IDE,ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX,NBE INTEGER TRIMAT(*),REFMAT(*),NMT INTEGER ITVL(*),NITMAX INTEGER INOEFR(*),INOMAX,IIRGFR(*),IRRGFR(*),IREMAX INTEGER NMTFR,NBEFR,NBNFR,IERR C INTEGER IEL,I,J,K,IMAT1,IMAT2,INDNF(4),NBRN,NBNF INTEGER IND,IFAC,ITRMX2,NUMEL,NUMCC INTEGER IVOIS,IFVOIS INTEGER IMAT,IVMAT,IELFRT,IREFRG,NRGMAX INTEGER NOEMAX,NBFMAX,ITRAV INTEGER STRNBN,STRKSF EXTERNAL STRNBN,STRKSF C C ---- CALCUL DE LA FRONTIERE ---- C IND = 1 IFAC = 1 ITRMX2 = NITMAX - IFAC C C CALL TMAFRT(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,IND,NBE, C > ITVL(IFAC),NBEFR,ITRMX2,IERR) C IF( IERR.NE. 0 )THEN C CALL DSERRE(1,IERR,'DRG2FR','APPEL TMAFRT') C GOTO 9999 C ENDIF C --- IL AURAIT FALLU CREER LES FRONTIERES INTER-MAT : SFRICR C NBEFR = 0 DO 7 I=1,NBE CALL REFREG(I,TRIMAT,REFMAT,NMT,IMAT1,IERR) IF(IERR.NE.0)THEN CALL DSERRE(1,IERR,'DRG2FR','1 APPEL REFREG') GOTO 9999 ENDIF DO 5 J=1,NBCMAX IVOIS = ITRTRI((I-1)*NBCMAX+J) IF( IVOIS .GT. I )GOTO 5 IF( IVOIS .GT. 0 )THEN CALL REFREG(IVOIS,TRIMAT,REFMAT,NMT,IMAT2,IERR) IF(IERR.NE.0)THEN CALL DSERRE(1,IERR,'DRG2FR','2 APPEL REFREG') GOTO 9999 ENDIF IF( IMAT1.NE.IMAT2 )THEN NBEFR = NBEFR + 1 ITVL((NBEFR-1)*2+1+IFAC-1) = I ITVL((NBEFR-1)*2+2+IFAC-1) = -J ENDIF ELSE NBEFR = NBEFR + 1 ITVL((NBEFR-1)*2+1+IFAC-1) = I ITVL((NBEFR-1)*2+2+IFAC-1) = J ENDIF 5 CONTINUE 7 CONTINUE C PRINT *,'IEL14 = ', ITVL((14-1)*2+1+IFAC-1) C PRINT *,'IF14 = ', ITVL((14-1)*2+2+IFAC-1) C C ---- CALCUL DES NOEUDS ET MATERIAUX ---- C C --- CARDINAUX --- C IF( NBNFR.EQ. 0 )THEN DO 10 IEL=1,NBEFR NUMEL = ITVL((IEL-1)*2+1+IFAC-1) NUMCC = ITVL((IEL-1)*2+2+IFAC-1) NBRN = STRNBN(NUMEL,ITRNOE,NBNMAX) NBNF = STRKSF(IDE,NBRN,ABS(NUMCC),INDNF) NBNFR = MAX(NBNFR,NBNF) 10 CONTINUE ENDIF C IF( NBNFR*NBEFR .GT. INOMAX )THEN IERR = -2 CALL DSERRE(1,IERR,'DRG2FR', > 'TROP DE NOEUDS DE FRONTIERE') C PRINT *,'NBNFR,NBEFR =', NBNFR,NBEFR C PRINT *,'IOMAX =', INOMAX GOTO 9999 ENDIF C C --- LES NOEUDS --- C DO 30 IEL=1,NBEFR NUMEL = ITVL((IEL-1)*2+1+IFAC-1) NUMCC = ITVL((IEL-1)*2+2+IFAC-1) NBRN = STRNBN(NUMEL,ITRNOE,NBNMAX) NBNF = STRKSF(IDE,NBRN,ABS(NUMCC),INDNF) IF( NBNF.GT.4 )THEN IERR = -2 CALL DSERRE(1,IERR,'DRG2FR', > 'UN COTE A PLUS DE 4 NOEUDS') GOTO 9999 ENDIF DO 20 K=1,NBNF INOEFR((IEL-1)*NBNFR+K)= > ITRNOE((NUMEL-1)*NBNMAX+INDNF(K)) 20 CONTINUE 30 CONTINUE C C --- LES MATERIAUX --- C NMTFR = 0 IREFRG = NBEFR*2 + IFAC NRGMAX = NMT*2 IELFRT = NRGMAX + IREFRG IF( IELFRT.GT.NITMAX )THEN IERR = -2 CALL DSERRE(1,IERR,'DRG2FR', > 'POUR LES MATERIAUX') GOTO 9999 ENDIF C DO 60 IEL=1,NBEFR NUMEL = ITVL((IEL-1)*2+1+IFAC-1) NUMCC = ITVL((IEL-1)*2+2+IFAC-1) CALL REFREG(NUMEL,TRIMAT,REFMAT,NMT,IMAT,IERR) IF( IERR.NE.0 )THEN CALL DSERRE(1,IERR,'DRG2FR','3 APPEL REFREG') GOTO 9999 ENDIF C C ---- TEST DES MATERIAUX --- C IVMAT = REFMAT(IMAT) IF( NUMCC.LT. 0 ) > IVMAT = -REFMAT(IMAT) C PRINT *,'NUMEL = ',NUMEL C > ,' NUMCC = ',NUMCC C > ,' IMAT = ',IMAT C > ,' IVMAT = ',IVMAT IMAT = 0 DO 35 I=1,NMTFR IF(IVMAT.EQ.ITVL(I+IREFRG-1))IMAT = I 35 CONTINUE IF( IMAT.EQ. 0 )THEN NMTFR = NMTFR+1 ITVL(NMTFR+IREFRG-1) = IVMAT ITVL(IEL+IELFRT-1) = IVMAT ELSE ITVL(IEL+IELFRT-1) = IVMAT ENDIF C C ---- FRONTIERE INTERNE ---- C --- SI LE MATERIAU EST DEJA REFERENCE ON VA VOIR LE VOISIN : C IF((NUMCC.LT. 0).AND.(IMAT.NE.0))THEN C PRINT *,'IEL = ',IEL IVOIS = ITRTRI((NUMEL-1)*NBCMAX-NUMCC) C PRINT *,'IVOIS = ',IVOIS CALL REFREG(IVOIS,TRIMAT,REFMAT,NMT,IMAT,IERR) IF( IERR.NE.0 )THEN CALL DSERRE(1,IERR,'DRG2FR','4 APPEL REFREG') GOTO 9999 ENDIF C C ---- TEST DES MATERIAUX --- C C PRINT *,'IMAT(IVOIS) = ',IMAT IVMAT = -REFMAT(IMAT) IMAT = 0 DO 37 I=1,NMTFR IF(IVMAT.EQ.ITVL(I+IREFRG-1))IMAT = I 37 CONTINUE IF( IMAT.NE. 0 )GOTO 60 C NMTFR = NMTFR+1 ITVL(NMTFR+IREFRG-1) = IVMAT ITVL(IEL+IELFRT-1) = IVMAT C C --- IL FAUT INVERSER L'ORDRE DES NOEUDS --- CALL SESFR1(NUMEL,-NUMCC, > ITRTRI,NBCMAX,IVOIS,IFVOIS) NBRN = STRNBN(IVOIS,ITRNOE,NBNMAX) NBNF = STRKSF(IDE,NBRN,ABS(IFVOIS),INDNF) DO 40 K=1,NBNF INOEFR((IEL-1)*NBNFR+K) = > ITRNOE((IVOIS-1)*NBNMAX+INDNF(K)) 40 CONTINUE ENDIF C 60 CONTINUE C C ---- RENUMEROTATION DES MATERIAUX CROISSANTS ---- C C PRINT *,'NOEUDS = ' C > ,( (INOEFR((I-1)*NBNFR+J),J=1,NBNFR) C > ,'/',I=1,NBEFR) C PRINT *,'NOMBRE DE MATERIAUX = ',NMTFR C PRINT *,'REFERENCES MATERIAUX = ', C > (ITVL(I+IREFRG-1),I=1,NMTFR) C PRINT *,'ELEMENTS = ', C > (ITVL(I+IELFRT-1),I=1,NBEFR) NOEMAX = 0 NBFMAX = 0 C --- ON NE DEPASSE PAS 2*NBEFR --- ITRAV = IFAC C ITRAV = NBEFR + IELFRT NRGMAX = 2*NMT C PRINT *,'IEL14 = ', ITVL((14-1)*2+1+IFAC-1) C PRINT *,'IF14 = ', ITVL((14-1)*2+2+IFAC-1) CALL RGCOMP(IDE,INOEFR,NBNFR, > ITVL(1),NBFMAX,ITVL(1), > NOEMAX,NBEFR,ITVL(ITRAV), > ITVL(IELFRT),ITVL(IREFRG),NMTFR, > IRRGFR,IIRGFR,NMTFR,NRGMAX,IERR) C PRINT *,'INTERVALS = ',(IIRGFR(I),I=1,NMTFR) C PRINT *,'NOEUDS = ' C > ,( (INOEFR((I-1)*NBNFR+J),J=1,NBNFR) C > ,'/',I=1,NBEFR) IF( IERR.NE. 0 )THEN CALL DSERRE(1,IERR,'DRG2FR','APPEL RGCOMP') GOTO 9999 ENDIF C 9999 END C C ***************************************************************** C FICHIER : DEBUG.F C OBJET : VERIFICATION DES PROPRIETES DE LA STRUCTURE DES DONNEES C DU MAILLAGE C FONCT. : C SDBTRI : VERIFIE LA STRUCTURE DE DONNEES POUR LES FRONTIERES C DES ELEMENTS (COHERANCE ITRTRI <-> ITRNOE) C SDBORI : VERIFIE L'ORIENTATION DES ELEMENTS C C AUTEUR : O. STAB C DATE : 03.95 C TESTS : O.STAB 03.95 C MODIFICATIONS : C AUTEUR, DATE, OBJET : O.STAB, 21.01.99, NETTOYAGE SDBTRI + EXT 3D C C C ***************************************************************** C SUBROUTINE SDBTRI(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI, > NBE,NOEMAX,ITRACE,IERR) C ***************************************************************** C OBJET SDBTRI : VERIFIE LA STRUCTURE DES DONNEES C (COHERANCE ITRTRI <-> ITRNOE, ITRNOE <-> NOETRI) C EN ENTREE : LE MAILLAGE C NOEMAX: SI > 0 ON VERIFIE NOETRI C ITRACE : NIVEAU D'AFFICHAGE 0 => RIEN SAUF LES ERREURS C 1 => ECHO DES TESTS EN COURS C EN SORTIE : IERR : 0 SI OK, -1 SI ERREUR C MODIF 21.01.99 : ON TOLERE L'ELEMENT VIDE (LES TROUS DANS LA C NUMEROTATION) C C REMARQUE : ATTENTION NOETRI EST NECESSAIRE A LA VERIFICATION C EN REVANCHE SI NOEMAX EST NON NUL IL N'EST PAS VERIFIE ! C ***************************************************************** INTEGER IDE,NBE,ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX,NOETRI(*) INTEGER NOEMAX,ITRACE,IERR C INTEGER I,J,K,IT(2),IFAC(4),N(2),NF(4),NNE,NCE,NBNF,IT2,IF2 INTEGER KK,NF2(4),NNE2,NBNF2 INTEGER NBFFR,II,JJ,JJ2,ISOM(4),NBNC,IF1,IFC,ITVL(10000),NITMAX INTEGER STRNBN,STRNBC,STRKSF,SFAIDE EXTERNAL STRNBN,STRNBC,STRKSF,SFAIDE C NITMAX = 10000 C IERR = 0 NBFFR = 0 C ==================================== C --- 1. VERIFICATION NOETRI <-> ITRNOE --- C ==================================== IF( NOEMAX.GT. 0 )THEN IF( ITRACE.GT.0)PRINT *,'VERIFICATION NOETRI <-> ITRNOE ' C --- POUR CHAQUE ELEMENT ---------------------------------- DO 20 I=1,NOEMAX K = NOETRI(I) IF((K.GT.NBE).OR.(K.LT.0))THEN PRINT *,'SDBTRI : ERREUR POSSIBLE NOETRI ',I,' = ',K IERR = -1 CALL DSERRE(1,IERR,'SDBTRI',' NOETRI') GOTO 9999 ENDIF IF( K .EQ. 0 )THEN PRINT *,'ATTENTION NOEUD ISOLE ',I GOTO 20 ENDIF C --- POUR CHAQUE NOEUD DE L'ELEMENT ----------- DO 10 J=1,NBNMAX IF( ITRNOE((K-1)*NBNMAX+J).EQ.I )GOTO 20 10 CONTINUE PRINT *,'ERREUR NOETRI ',I,' = ',K PRINT *,' ITRNOE',K,' = ', > (ITRNOE((K-1)*NBNMAX+J),J=1,NBNMAX) IERR = -1 CALL DSERRE(1,IERR,'SDBTRI',' NOETRI <-> ITRINOE') GOTO 9999 20 CONTINUE IF(ITRACE.NE.0)PRINT *,' --> OK' ENDIF C ==================================== C --- 2. VERIFICATION ITRTRI <-> ITRNOE --- C ==================================== IF( ITRACE.GT.0)PRINT *,'VERIFICATION ITRTRI <-> ITRNOE ' C C --- POUR CHAQUE ELEMENT ---------------------------------- C --------------------- DO 100 I=1,NBE NNE = STRNBN(I,ITRNOE,NBNMAX) IF(NNE.EQ.0)THEN PRINT *,'ATTENTION A L ELEMENT :',I,' DE ',NNE,' NOEUDS' PRINT *,'NOEUDS = ',(ITRNOE((I-1)*NBNMAX+J),J=1,NBNMAX) ENDIF IF( IDE.EQ.2 )THEN IF((NNE.GT.4).OR.(NNE.LT.3))THEN PRINT *,'ATTENTION A L ELEMENT :',I,' DE ',NNE,' NOEUDS' PRINT *,'NOEUDS = ',(ITRNOE((I-1)*NBNMAX+J),J=1,NBNMAX) ENDIF ENDIF IF( IDE.EQ.3 )THEN IF((NNE.LT.4).OR.(NNE.GT.8))THEN PRINT *,'ATTENTION A L ELEMENT :',I,' DE ',NNE,' NOEUDS' PRINT *,'NOEUDS = ',(ITRNOE((I-1)*NBNMAX+J),J=1,NBNMAX) ENDIF ENDIF NCE = STRNBC(NNE,IDE) C --- ON PASSE A L'ELEMENT SUIVANT --- IF( NNE.EQ.0 )GOTO 100 C ------------------------------- C --- POUR CHAQUE FACE DE L'ELEMENT ----------- C ------------------------------- DO 90 J=1,NCE NBNF = STRKSF(IDE,NNE,J,NF) DO 80 K=1,NBNF NF(K) = ITRNOE((I-1)*NBNMAX+NF(K)) 80 CONTINUE C C --- ON PART DU TABLEAU DES VOISINS : ITRTRI -------- C ELEMENT SUIVANT SUR LA FRONTIERE CALL SESFR1(I,J,ITRTRI,NBCMAX,IT2,IF2) C C --- ON PART DES NOEUDS DE LA FACE NF : NOETRI PUIS ITRTRI C IF( IDE.EQ.2 )THEN C IF( IDE.EQ.2 )THEN C ?? INTERET ?? <- reactive le 01/04/2003 CALL SFRIDE(NF,NBNF,IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX, > NOETRI,NBE,ITVL,NITMAX, > IT(1),IT(2),IFAC(1),IFAC(2),IERR) IF(IERR.NE.0)THEN CALL DSERRE(1,IERR,'SDBTRI',' APPEL SFRIDE') GOTO 9999 ENDIF ELSE C ---- SFRIDE NE MARCHE PAS EN 3D --------------- IT(1) = I IFAC(1) = J IT(2) = IT2 IFAC(2) = IF2 ENDIF C IF(((IT(2).NE.I).OR.(IT2.NE.IT(1))).AND. > ((IT(1).NE.I).OR.(IT2.NE.IT(2))))THEN PRINT *,'ATTENTION : SFRIDE ET ITRTRI INCOMPATIBLES' PRINT *,'( ',IT(1),IT(2),' ) DIFFERENT (',I,IT2,' )' IERR = -1 CALL DSERRE(1,IERR,'SDBTRI',' ITRTRI<-> ITRNOE ') GOTO 9999 ENDIF IF((IT(1).GT.NBE).OR.(IT(2).GT.NBE))THEN PRINT *,'ATTENTION ',IT(1),IT(2),' SUPERIEUR A ',NBE ENDIF C C --- ON PART DES NOEUDS DES ELEMENTS : ITRNOE -- C IF((IT(1).NE.0).AND.(IT(2).NE.0))THEN N(1) = STRNBN(IT(1),ITRNOE,NBNMAX) N(2) = STRNBN(IT(2),ITRNOE,NBNMAX) IFAC(3) = 0 IFAC(4) = 0 IFC = SFAIDE(ITRNOE((IT(1)-1)*NBNMAX+1), > ITRNOE((IT(2)-1)*NBNMAX+1),N(1),N(2),IDE,IFAC(3), > IFAC(4)) C -------------------------------------------------- C ON DOIT RETROUVER EGALITE DES INDICES DES FACES C -------------------------------------------------- IF((IFAC(3).NE.IFAC(1)).OR.(IFAC(4).NE.IFAC(2)).OR. > (ABS(ITRTRI((IT(1)-1)*NBCMAX+IFAC(1))).NE.IT(2)).OR. > (ABS(ITRTRI((IT(2)-1)*NBCMAX+IFAC(2))).NE.IT(1)))THEN PRINT *,'ERREUR SUR LE COTE ',J,' DE ELEMENT ',I PRINT *,'NOEUDS = ',(ITRNOE((I-1)*NBNMAX+K),K=1,NBNMAX) PRINT *,'VOISINS= ',(ITRTRI((I-1)*NBCMAX+K),K=1,NBCMAX) C LA SUITE EST POUR LES MESSAGES : C -------------------------------------------------- IF(IFAC(3).NE.IFAC(1))PRINT *,'ERREUR ', > IT(1),' ADJACENT A ',IT(2),' SUR ',IFAC(1),' OU SUR ',IFAC(3) C -------------------------------------------------- IF(IFAC(4).NE.IFAC(2))PRINT *,'ERREUR ', > IT(1),' ADJACENT A ',IT(2),' SUR ',IFAC(2),' OU SUR ',IFAC(4) C -------------------------------------------------- IF(ABS(ITRTRI((IT(1)-1)*NBCMAX+IFAC(1))).NE.IT(2)) > PRINT *,'ERREUR L ELEMENT ADJACENT A ', > IT(1),' SUR ',IFAC(1),' EST ', > ABS(ITRTRI((IT(1)-1)*NBCMAX+IFAC(1))),' OU ',IT(2) C -------------------------------------------------- IF(ABS(ITRTRI((IT(2)-1)*NBCMAX+IFAC(2))).NE.IT(1)) > PRINT *,'ERREUR L ELEMENT ADJACENT A ', > IT(2),' SUR ',IFAC(2),' EST ', > ABS(ITRTRI((IT(2)-1)*NBCMAX+IFAC(2))),' OU ',IT(1) C ---- FIN DES MESSAGES ---- IERR = -1 CALL DSERRE(1,IERR,'SDBTRI',' ITRTRI <-> ITRNOE') GOTO 9999 ENDIF C -------------------------------------------------- C ON DOIT RETROUVER EGALITE DES NOEUDS NF ET NF2 C -------------------------------------------------- NNE2 = STRNBN(IT2,ITRNOE,NBNMAX) NBNF2 = STRKSF(IDE,NNE2,IF2,NF2) DO 180 K=1,NBNF2 NF2(K) = ITRNOE((IT2-1)*NBNMAX+NF2(K)) 180 CONTINUE IF( NBNF.NE.NBNF2 )THEN PRINT *,'SDBTRI : LES CARD DES FACES DIFFERENT ',NBNF,NBNF2 IERR = -1 CALL DSERRE(1,IERR,'SDBTRI',' CARD DES FACES') GOTO 9999 ENDIF C DO 190 K=1,NBNF IF( NF(1).EQ.NF2(K) )GOTO 200 190 CONTINUE PRINT *,'SDBTRI : FACES DIFFERENT ',NF(1),' INTROUVABLE' IERR = -1 CALL DSERRE(1,IERR,'SDBTRI',' LES FACES') GOTO 9999 C 200 CONTINUE KK = K DO 210 K=1,NBNF IF(NF(K).NE.NF2(KK))THEN PRINT *,'SDBTRI : FACES DIFFERENTES' IERR = -1 CALL DSERRE(1,IERR,'SDBTRI',' LES FACES') GOTO 9999 ENDIF KK = NBNF - MOD(NBNF+1-KK,NBNF) 210 CONTINUE ELSE C C --- VERIFIONS QUE NF(K) EST SUR LA FRONTIERE ----------- C ------------------------------------------ CALL KNUTA(NBNF,NF) DO 1150 II=I+1,NBE C --- ON TESTE TOUS LES ELEMENTS SUIVANTS --- DO 1100 K=1,NBNMAX ISOM(K) = ITRNOE((II-1)*NBNMAX+K) 1100 CONTINUE CALL KNUTA(NBNMAX,ISOM) NBNC = 0 JJ2 = 1 JJ = 1 C ---- PAS DE FACE EN COMMUN ON PASSE AU SUIVANT ----- 1105 IF((JJ2.GT.NBNF ).OR.(JJ.GT.NBNMAX))GOTO 1150 IF(ISOM(JJ).GT.NF(JJ2))THEN JJ2 = JJ2 + 1 ELSE IF(ISOM(JJ).LT.NF(JJ2))THEN JJ = JJ + 1 ELSE NBNC = NBNC+1 JJ = JJ + 1 JJ2 = JJ2 + 1 ENDIF ENDIF IF( NBNC.NE.NBNF )GOTO 1105 C ---- LA FACE NE FAIT PAS PARTIE DE LA FRONTIERE ----- IF(NBNC.EQ.NBNF)THEN WRITE(*,*) 'ERREUR SUR LA FRONTIERE :' WRITE(*,*) 'SUR LA FACE ',J,' DE L ELEMENT ',I WRITE(*,*) 'IL Y A L ELEMENT : ',II WRITE(*,*) 'LA FACE ',NF(1),NF(2),NF(3), > ' N EST PAS SUR LA FRONTIERE' IFC = SFAIDE(ITRNOE((I-1)*NBNMAX+1), > ITRNOE((II-1)*NBNMAX+1), NBNMAX, NBNMAX, > IDE, IF1, IF2 ) * APPEL = SFAC3D IF(IFC.NE.0)THEN WRITE(*,*)'ELEMENT ',II,' SUR FACE ',IF2 ELSE WRITE(*,*)'SFAIDE SE PLANTE AUSSI ' ENDIF IERR = -1 CALL DSERRE(1,IERR,'SDBTRI',' ITRTRI <-> ITRNOE') ENDIF C 1150 CONTINUE NBFFR = NBFFR + 1 ENDIF C 90 CONTINUE 100 CONTINUE C IF((ITRACE.NE.0).AND.(IERR.EQ.0))THEN PRINT *,' NOMBRE DE FACES DE LA FRONTIERE = ',NBFFR PRINT *,' --> OK' ENDIF 9999 END C SUBROUTINE SDBORI(IDE,IDIMC,ITRNOE,NBNMAX,ITRTRI,NBCMAX, > NOETRI,NBE,COORD,ITRACE,IERR) C ***************************************************************** C OBJET : VERIFIE L'ORIENTATION DES ELEMENTS C EN ENTREE : LE MAILLAGE C ITRACE : NIVEAU D'AFFICHAGE 0 => RIEN SAUF LES ERREURS C 1 => ECHO DES TESTS EN COURS C EN SORTIE : IERR : 0 SI OK, -1 SI ERREUR C ***************************************************************** INTEGER IDE,IDIMC,NBE,ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX INTEGER NOETRI(*),ITRACE,IERR REAL COORD(*) C INTEGER NNE,NCE,I,J INTEGER STRNBN,STRNBC,GORIEN EXTERNAL STRNBN,STRNBC,GORIEN REAL ZERO C REAL TAILLE,RIL,TTVO,TTRIL C EXTERNAL TTVO,TTRIL C C A FAIRE : SI ZERO EST ABSOLU IL FAUDRAIT NORMALISER L'ESPACE C LE MIEUX SERAIT DE RELATIVISER LE TEST... ZERO = 1.E-6 IERR = 0 IF( ITRACE.NE.0)PRINT *,'SDBORI : VERIFICATION DE L ORIENTATION' DO 20 I=1,NBE NNE = STRNBN(I,ITRNOE,NBNMAX) NCE = STRNBC(NNE,IDE) C MODIF O.STAB 12.12.97 AJOUT IDE. IF( GORIEN(ITRNOE((I-1)*NBNMAX+1),NCE,IDE,COORD,IDIMC,ZERO) > .NE.1 )THEN PRINT *,'SDBORI : ERREUR SUR L ELEMENT ',I PRINT *,'SDBORI : NOEUDS = ', > (ITRNOE((I-1)*NBNMAX+J),J=1,NBNMAX) IERR = -1 ENDIF C C TAILLE = TTVO( COORD( (ITRNOE((I-1)*NBNMAX+1)-1)*IDIMC+1), C > COORD( (ITRNOE((I-1)*NBNMAX+2)-1)*IDIMC+1), C > COORD( (ITRNOE((I-1)*NBNMAX+3)-1)*IDIMC+1), C > COORD( (ITRNOE((I-1)*NBNMAX+4)-1)*IDIMC+1)) C IF( TAILLE .LT. 1.E-3 )THEN C PRINT *,'SDBORI : ERREUR ',I,' VOLUME = ',TAILLE C PRINT *,'SDBORI : NOEUDS = ', C > (ITRNOE((I-1)*NBNMAX+J),J=1,NBNMAX) C IERR = -1 C ENDIF C RIL = TTRIL( COORD( (ITRNOE((I-1)*NBNMAX+1)-1)*IDIMC+1), C > COORD( (ITRNOE((I-1)*NBNMAX+2)-1)*IDIMC+1), C > COORD( (ITRNOE((I-1)*NBNMAX+3)-1)*IDIMC+1), C > COORD( (ITRNOE((I-1)*NBNMAX+4)-1)*IDIMC+1)) C IF( RIL .LT. 1.E-4 )THEN C PRINT *,'SDBORI : ERREUR ',I,' RIL = ',RIL C PRINT *,'SDBORI : ERREUR ',I,' VOLUME = ',TAILLE C PRINT *,'SDBORI : NOEUDS = ', C > (ITRNOE((I-1)*NBNMAX+J),J=1,NBNMAX) C IERR = -1 C ENDIF C 20 CONTINUE C IF((ITRACE.NE.0).AND.(IERR.EQ.0))PRINT *,'SDBORI : ',NBE > ,' ELEMENTS > ',ZERO,' --> OK' 999 END C ***************************************************************** C MODULE : M1 (RAFFINEMENT LINEIQUE) C FICHIER : M1_DENSDEF.F C OBJET : DENSITE PAR DEFAUT D'UN MAILLAGE LINEIQUE C C FONCT. : C C D1DSLN: DONNE LA DENSITE PAR DEFAUT SUR DES ARETES C C AUTEUR : O. STAB C DATE : 08.95 C TESTS : 08.95 C MODIFICATIONS : C AUTEUR, DATE, OBJET : O.STAB, 12.12.97, AJOUT IDE APPEL GTAILL. C AUTEUR, DATE, OBJET : O.STAB, 11.08.98, SUP. DE LA STRUCTURE C C C ***************************************************************** C C SUBROUTINE D1DSLN(ITYPS,RSG, > ITRINO,NBNMAX,COORD,IDIMC,NBE, > TSN,NTSMAX,IERR) C ***************************************************************** C OBJET D1DSLN : DONNE LA DENSITE PAR DEFAUT C C EN ENTREE: C --------- DEFINITION DE L'AMORTISSEMENT -------- C ITYPS : TYPE DE LA PROGRESSION (GEOM. = 1, ARITH. = 2) C RSG : RAPPORT MAX ENTRE 2 ELEMENTS SUCCESSIFS (GEOM.) C DIFFERENCE MAX " " " " (ARITH.) C C --------- LE MAILLAGE --------------------- C ITRINO,NBNMAX : LE MAILLAGE C NOEMAX: SI = 0 ON NE REMPLI PAS NOETRI C SINON = NCOMAX C COORD,IDIMC : COORDONNEES DES NOEUDS C C NTSMAX : TAILLE DE TSN. C C EN SORTIE : C C TSN : TABLEAU DES TAILLES SOUHAITEES C TSN(I) = TAILLE SOUHAITE AU NOEUD I C IERR : CODE D'ERREUR 0 SI OK C -1 SI LES DONNEES SONT INCORRECTES C -2 SI TSN EST TROP PETIT C C NOUVEAU ALGORITHME : ON A PAS BESOIN DE LA STRUCTURE, ON PEUT C TRAITER LES ARETES DANS UN ORDRE ARBITRAIRE ! C DU MEME COUT ON EST PLUS LIMITE A DU MONO-MATERIAU ! C ***************************************************************** INTEGER ITYPS REAL RSG INTEGER NBE,ITRINO(*),NBNMAX REAL COORD(*) INTEGER IDIMC REAL TSN(*) INTEGER NTSMAX INTEGER IERR C INTEGER IT,IO,IE,J REAL TIT,VSD,X INTEGER IMODIF C TAILLE MAXI POUR INITIALISATION : PARAMETER (TSNMAX = 1.E+38) REAL TSNMAX PARAMETER (TSNMAX = 1.E+38) C IERR = 0 C ------------------------------------- C --- TAILLE SOUHAITE = TAILLE DES ARETES --- C ------------------------------------- C DO 10 IT=1,NBE IE = ITRINO((IT-1)*NBNMAX+2) IO = ITRINO((IT-1)*NBNMAX+1) IF((IE.GT.NTSMAX).OR.(IO.GT.NTSMAX))THEN IERR = -2 CALL DSERRE(1,IERR,'D1DSLN','TABLEAU TSN TROP PETIT') GOTO 9999 ENDIF TSN(IO) = TSNMAX TSN(IE) = TSNMAX 10 CONTINUE C 15 CONTINUE IMODIF = 0 DO 30 IT=1,NBE IE = ITRINO((IT-1)*NBNMAX+2) IO = ITRINO((IT-1)*NBNMAX+1) TIT = 0.0 DO 20 J=1,IDIMC X = COORD(((IE-1)*IDIMC)+J) > - COORD(((IO-1)*IDIMC)+J) TIT = TIT + X*X 20 CONTINUE TIT = SQRT( TIT ) C TSN( IE ) = MIN(TIT,TSN(IE)) CALL SCSUPO(ITYPS,TSN(IO),RSG,TIT,VSD) IF( VSD.LT.TSN(IE))THEN IMODIF = 1 TSN( IE ) = VSD ENDIF C TSN( IO ) = MIN(TIT,TSN(IO)) CALL SCSUPO(ITYPS,TSN(IE),RSG,TIT,VSD) IF( VSD.LT.TSN(IO))THEN IMODIF = 1 TSN( IO ) = VSD ENDIF 30 CONTINUE IF(IMODIF.GT.0)GOTO 15 9999 END C C **************************************************************** C MODULE : M1 (RAFFINEMENT LINEIQUE) C FICHIER : M1_DENSITE1D.F C OBJET : FONCTION ANALYTIQUES DE CALCUL DE LA DENSITE C C FONCT. : C OBJET D1SUM : CALCUL LES PTS (SUITE MONOTONE SEGMENT) (LOCAL) C OBJET D1SU : DENSITE DEFINIE PAR UNE SUITE A PARTIR D'UN OBJET (OBSOLET) C OBJET D1SU2 : DENSITE DEFINIE PAR UNE SUITE A PARTIR D'UN OBJET C OBJET D1ISU : DENSITE DEFINIE PAR UNE SUITE A PARTIR D'UN OBJET C OBJET D1SUI : CF. D1SU MODE ITERATIF C OBJET D1ISUI : CALCULE LA TAILLE SOUHAITE D'UN ELEMENT (IT) C -------- DECOUPAGE DIRECT -------------- C C -------- DECOUPAGE ITERATIF ------------ C C AUTEUR : O. STAB C DATE : 03.95 / 06.95 / 05.98 C TESTS : 07.95 C MODIFICATIONS : C AUTEUR, DATE, OBJET : C C C **************************************************************** C SUBROUTINE D1SUM(XP1,XP2,IDIMC,ITYPS,TSP,RSG,ITYPO, > ROBJET,XPI,NBPMAX,NBPI,IERR) C **************************************************************** C OBJET D1SUM : CALCUL LES PTS (SUITE MONOTONE SEGMENT) (LOCAL) C C EN ENTREE : C XP1 : DEBUT DU SEGMENT C XP2 : FIN DU SEGMENT C IDIMC : DIMENSION DE L'ESPACE C --------------------- C ITYPO : TYPE DE L'OBJET C ROBJET : LA DEFINITION GEOMETRIQUE DE L'OBJET C ITYPS : TYPE DE LA SUITE C TSP : LA TAILLE SOUHAITE A L'OBJET C RSG : RAISON DE LA SUITE GEOMETRIQUE C NBPMAX : TAILLE MAXI DU TABLEAU DES POINTS C C EN SORTIE : C XPI : COORDONNEES DES POINTS CALCULES C NBPI : NOMBRE DE NOEUDS CALCULES C **************************************************************** REAL XP1(*),XP2(*) INTEGER IDIMC,ITYPS,ITYPO REAL TSP,RSG,ROBJET(*),XPI(*) INTEGER NBPMAX,NBPI,IERR C REAL TS1,TS2,D1,D2 EXTERNAL SU2PO,POSUM REAL ZERO COMMON /CSTGEO/ZERO C IERR = 0 C --- CALCUL DES DISTANCES A L'OBJET ------------------------ CALL DIPOOB(IDIMC,XP1,ITYPO,ROBJET,D1,IERR) IF( IERR .NE. 0 )GOTO 888 CALL DIPOOB(IDIMC,XP2,ITYPO,ROBJET,D2,IERR) IF( IERR .NE. 0 )GOTO 888 C --- CALCUL DE LA DENSITE AUX POINTS ----------------------- CALL SCSUPO(ITYPS,TSP,RSG,D1,TS1) CALL SCSUPO(ITYPS,TSP,RSG,D2,TS2) IF((TS2.LE.ZERO).OR.(TS1.LE.ZERO))THEN IERR = -1 CALL DSERRE(1,IERR,'M1', > 'DANS D1SUM : TAILLE SOUHAITE NEGATIVE OU NULLE') GOTO 999 ENDIF C --- CALCUL DE LA SUITE ------------------------------------ CALL POSUM(XP1,XP2,IDIMC,TS1,TS2,ITYPS, > XPI,NBPMAX,NBPI,IERR) C 888 IF( IERR .NE. 0 )CALL DSERRE(1,IERR,'M1','DANS D1SUM') 999 END C C SUBROUTINE D1SU2(XP1,XP2,IDIMC,ITYPS,TSP,RSG,ITYPO,ROBJET, > XPI,NBPMAX,NBPI,IERR) C **************************************************************** C OBJET D1SU2 : DENSITE DEFINIE PAR UNE SUITE A PARTIR D'UN OBJET version 19.01.2005 C (POINT,AXE) POUR UN ELEMENT 1D (ARETE) C EN ENTREE : C -------- DEFINITION DU SEGMENT ---------------------- C XP1 : COORDONNEES DE L'ORIGINE DU SEGMENT C XP2 : COORDONNEES DE L'EXTREMITE DU SEGMENT C IDIMC : DIMENSION DE L'ESPACE (1 OU 2) C -------- DEFINITION DE LA CONCENTRATION ------------- C ITYPO : TYPE DE CONCENTRATION C ROBJET : LA DEFINITION GEOMETRIQUE DE LA CONCENTRATION C ITYPS : TYPE DE LA SUITE C TSP : LA TAILLE SOUHAITE A LA CONCENTRATION C RSG : RAISON DE LA SUITE GEOMETRIQUE C NBPMAX : NOMBRE MAXIMUM DE POINTS DANS XPI C C EN SORTIE : C XPI : COORDONNEES DES POINTS CALCULES C NBPI : NOMBRE DE POINTS CALCULES C IERR : CODE D'ERREUR C REMARQUE : generalise D1SU car le nombre de points sur le segment C peut etre = 4 dans le cas non monotone. C **************************************************************** REAL XP1(*),XP2(*) INTEGER IDIMC,ITYPS,ITYPO REAL TSP,RSG,ROBJET(*),XPI(*) INTEGER NBPMAX,NBPI,IERR C C nombre maximum de points (de changement de densite) sur un segment REAL TS1,TS2,D1,D2,DNUL(4) REAL TSNUL(4),XPNUL(3*4) INTEGER MONO,I REAL ZERO COMMON /CSTGEO/ZERO C IERR = 0 MONO = 0 CALL DIMONO(XP1,XP2,IDIMC,ITYPO,ROBJET,XPNUL,MONO,IERR) IF( IERR .NE. 0 )GOTO 888 IF( MONO .NE. 0 )THEN C ============================= C --- LA SUITE N'EST PAS MONOTONE --- C ============================= C ------------------------------------------ C --- CALCUL DE LA DENSITE AUX "MONO"+2 POINTS --------- C ------------------------------------------ DO 10 I=1,MONO CALL DIPOOB(IDIMC,XPNUL((I-1)*IDIMC+1), > ITYPO,ROBJET,DNUL(I),IERR) 10 CONTINUE IF( IERR .NE. 0 )GOTO 888 CALL DIPOOB(IDIMC,XP1,ITYPO,ROBJET,D1,IERR) IF( IERR .NE. 0 )GOTO 888 CALL DIPOOB(IDIMC,XP2,ITYPO,ROBJET,D2,IERR) IF( IERR .NE. 0 )GOTO 888 DO 20 I=1,MONO CALL SCSUPO(ITYPS,TSP,RSG,DNUL(I),TSNUL(I)) 20 CONTINUE CALL SCSUPO(ITYPS,TSP,RSG,D1,TS1) CALL SCSUPO(ITYPS,TSP,RSG,D2,TS2) IF((TS1.LE.ZERO).OR.(TS2.LE.ZERO))THEN IERR = -1 CALL DSERRE(1,IERR,'D1SU2', > 'TAILLE SOUHAITE NEGATIVE OU NULLE') GOTO 999 ENDIF CALL POSUNM2(XP1,XPNUL,MONO,XP2,IDIMC,TS1,TSNUL,TS2,ITYPS, > XPI,NBPMAX,NBPI,IERR) ELSE C ============================= C --- LA SUITE EST MONOTONE --- C ============================= CALL D1SUM(XP1,XP2,IDIMC,ITYPS,TSP,RSG,ITYPO, > ROBJET,XPI,NBPMAX,NBPI,IERR) ENDIF C 888 IF( IERR .NE. 0 )CALL DSERRE(1,IERR,'D1SU','DANS D1SU') 999 END C C SUBROUTINE D1SU(XP1,XP2,IDIMC,ITYPS,TSP,RSG,ITYPO,ROBJET, > XPI,NBPMAX,NBPI,IERR) C **************************************************************** C OBJET D1SU : DENSITE DEFINIE PAR UNE SUITE A PARTIR D'UN OBJET (OBSOLET) C (POINT,AXE) POUR UN ELEMENT 1D (ARETE) C EN ENTREE : C -------- DEFINITION DU SEGMENT ---------------------- C XP1 : COORDONNEES DE L'ORIGINE DU SEGMENT C XP2 : COORDONNEES DE L'EXTREMITE DU SEGMENT C IDIMC : DIMENSION DE L'ESPACE (1 OU 2) C -------- DEFINITION DE LA CONCENTRATION ------------- C ITYPO : TYPE DE CONCENTRATION C ROBJET : LA DEFINITION GEOMETRIQUE DE LA CONCENTRATION C ITYPS : TYPE DE LA SUITE C TSP : LA TAILLE SOUHAITE A LA CONCENTRATION C RSG : RAISON DE LA SUITE GEOMETRIQUE C NBPMAX : NOMBRE MAXIMUM DE POINTS DANS XPI C C EN SORTIE : C XPI : COORDONNEES DES POINTS CALCULES C NBPI : NOMBRE DE POINTS CALCULES C IERR : CODE D'ERREUR C **************************************************************** REAL XP1(*),XP2(*) INTEGER IDIMC,ITYPS,ITYPO REAL TSP,RSG,ROBJET(*),XPI(*) INTEGER NBPMAX,NBPI,IERR C REAL TS1,TS2,D1,D2,DNUL REAL TSNUL,XPNUL(3) INTEGER MONO REAL ZERO COMMON /CSTGEO/ZERO C IERR = 0 MONO = 1 CALL DIMONO(XP1,XP2,IDIMC,ITYPO,ROBJET,XPNUL,MONO,IERR) IF( IERR .NE. 0 )GOTO 888 IF( MONO .NE. 0 )THEN C ============================= C --- LA SUITE N'EST PAS MONOTONE --- C ============================= C ----------------------------------- C --- CALCUL DE LA DENSITE AUX 3 POINTS --------- C ----------------------------------- CALL DIPOOB(IDIMC,XPNUL,ITYPO,ROBJET,DNUL,IERR) IF( IERR .NE. 0 )GOTO 888 CALL DIPOOB(IDIMC,XP1,ITYPO,ROBJET,D1,IERR) IF( IERR .NE. 0 )GOTO 888 CALL DIPOOB(IDIMC,XP2,ITYPO,ROBJET,D2,IERR) IF( IERR .NE. 0 )GOTO 888 CALL SCSUPO(ITYPS,TSP,RSG,DNUL,TSNUL) CALL SCSUPO(ITYPS,TSP,RSG,D1,TS1) CALL SCSUPO(ITYPS,TSP,RSG,D2,TS2) IF((TSNUL.LE.ZERO).OR.(TS1.LE.ZERO).OR.(TS2.LE.ZERO))THEN IERR = -1 CALL DSERRE(1,IERR,'M1', > 'DANS D1SU : TAILLE SOUHAITE NEGATIVE OU NULLE') GOTO 999 ENDIF CALL POSUNM(XP1,XPNUL,XP2,IDIMC,TS1,TSNUL,TS2,ITYPS, > XPI,NBPMAX,NBPI,IERR) ELSE C ============================= C --- LA SUITE EST MONOTONE --- C ============================= CALL D1SUM(XP1,XP2,IDIMC,ITYPS,TSP,RSG,ITYPO, > ROBJET,XPI,NBPMAX,NBPI,IERR) ENDIF C 888 IF( IERR .NE. 0 )CALL DSERRE(1,IERR,'M1','DANS D1SU') 999 END C C SUBROUTINE D1ISU(XP1,XP2,IDIMC,ITAB,RTAB,XPI,NBPMAX, > NBPI,IERR) C **************************************************************** C OBJET D1ISU : DENSITE DEFINIE PAR UNE SUITE A PARTIR D'UN OBJET C (POINT,AXE) POUR UN ELEMENT 1D (ARETE) C FONCTION PARAMETRE POUR RAF1D MODE DIRECT C APPEL D1SU C EN ENTREE : C --------- L'ARETE A RAFFINER ------------------- C XP1 : COORDONNEES DU POINT ORIGINE DU SEGMENT C XP2 : COORDONNEES DU POINT EXTREMITE DU SEGMENT C IDIMC : DIMENSION DE L'ESPACE (1 OU 2) C NBPMAX : NOMBRE MAXIMUM DE POINTS DANS XPI C C --------- DEFINITION DE LA CONCENTRATION ------------ C ITAB(1) : TYPE DE LA SUITE (1=GEOMETRIQUE, 2=ARITHEMTIQUE) C ITAB(2) : TYPE DE LA CONCENTRATION (1=POINT, 2=DROITE) C RTAB(1) : RAISON DE LA SUITE GEOMETRIQUE C RTAB(2) : TAILLE SOUHAITE A LA CONCENTRATION C RTAB(3...): COORDONNEES DES POINTS DEFINISSANT LA GEOMETRIE C DE LA CONCENTRATION : C - UN SEUL POINT SI ITAB(2) = 1 C - DEUX POINTS SI ITAB(2) = 2 C C EN SORTIE : C XPI : COORDONNEES DES POINTS CALCULES C NBPI : NOMBRE DE POINTS CALCULES C IERR : CODE D'ERREUR C 0 SI OK C -1 SI LES DONNEES SONT ERRONEES C **************************************************************** REAL XP1(*), XP2(*) INTEGER IDIMC,ITAB(*) REAL RTAB(*),XPI(*) INTEGER NBPMAX,NBPI,IERR C C CALL D1SU(XP1,XP2,IDIMC,ITAB(1),RTAB(2),RTAB(1), CALL D1SU2(XP1,XP2,IDIMC,ITAB(1),RTAB(2),RTAB(1), > ITAB(2),RTAB(3),XPI,NBPMAX,NBPI,IERR) 999 END C C SUBROUTINE D1SUI(XP1,XP2,TAILEL,IDIMC, > ITYPS,TSP,RSG, > ITYPO,ROBJET,COEF,TS,IERR) C ***************************************************************** C OBJET D1SUI : CF. D1SU MODE ITERATIF C EN ENTREE : C XP1 : COORDONNEES DE L'ORIGINE DU SEGMENT C XP2 : COORDONNEES DE L'EXTREMITE DU SEGMENT C TAILEL : TAILLE DU SEGMENT C IDIMC : DIMENSION DE L'ESPACE (1 OU 2) C --------------------- C ITYPO : TYPE DE CONCENTRATION C ROBJET : LA DEFINITION GEOMETRIQUE DE LA CONCENTRATION C ITYPS : TYPE DE LA SUITE C TSP : LA TAILLE SOUHAITE A LA CONCENTRATION C RSG : RAISON DE LA SUITE GEOMETRIQUE C NBPMAX : TAILLE MAXI DU TABLEAU DES POINTS C EN SORTIE : C IERR : CODE D'ERREUR C 0 SI OK C -1 SI LES DONNEES SONT ERRONEES C REMARQUES IMPORTANTES: C LE DECOUPAGE EST ITERATIF : AU BARYCENTRE SI LA TAILLE C SOUHAITE EST < 1.5 TAILLE REELLE C (LA TAILLE SOUHAITE EST EVALUEE AU BARYCENTRE) C **************************************************************** INTEGER IDIMC,ITYPO,ITYPS REAL XP1(*),XP2(*),ROBJET(*),TSP,RSG REAL TAILEL REAL COEF,TS INTEGER IERR C REAL BARYC(3), V12(3),DBARYC EXTERNAL SCALVE,XNORVE REAL SCALVE,XNORVE C ==================== C ------ TEST AU BARYCENTRE ------ C ==================== CALL SOMMVE(XP2,XP1,IDIMC,V12) CALL MUSCVE(V12,0.5,IDIMC,BARYC) CALL DIPOOB(IDIMC,BARYC,ITYPO,ROBJET,DBARYC,IERR) IF( IERR.LT.0 )THEN CALL DSERRE(1,IERR,'M1','DANS D1SUI') GOTO 9999 ENDIF CALL SCSUPO(ITYPS,TSP,RSG,DBARYC,TS) C IF( TAILEL.LE.0 )THEN CALL DIFFVE(XP2,XP1,IDIMC,V12) TAILEL = XNORVE(V12,IDIMC) ENDIF IF( TAILEL.LE.1.E-10 )THEN IERR = -1 CALL DSERRE(1,IERR,'D1SUI','SEGMENT NUL') GOTO 9999 ENDIF COEF = TS / TAILEL C 9999 END C C SUBROUTINE D1ISUI(IT,ITRNOE,NBNMAX,ITRTRI,NBCMAX, > COORD,IDIMC,TAIREL,NBTMAX,ITAB,RTAB,COEF,TS,IERR) C **************************************************************** C OBJET D1ISUI : CALCULE LA TAILLE SOUHAITE D'UN ELEMENT (IT) C FONCTION PARAMETRE POUR RAF1D MODE ITERATIF C APPEL D1ISUI C EN ENTREE : C --------- L'ELEMENT A RAFFINER ------------------- C IT : NUMERO DE L'ELEMENT A RAFFINER C ITRNOE,NBNMAX,ITRTRI,NBCMAX : LE MAILLAGE C ITRTRI,NBCMAX (INUTILISES) C COORD,IDIMC : COORDONNEES DANS L'ESPACE DE DIMENSION IDIMC C TAIREL,NBTMAX : TAILLE REELLE DE L'ELEMENT C --------- DEFINITION DE LA CONCENTRATION ------------ C ITAB(1) : TYPE DE LA SUITE (1=GEOMETRIQUE, 2=ARITHEMTIQUE) C ITAB(2) : TYPE DE LA CONCENTRATION (1=POINT, 2=DROITE) C RTAB(1) : RAISON DE LA SUITE GEOMETRIQUE C RTAB(2) : TAILLE SOUHAITE A LA CONCENTRATION C RTAB(3...): COORDONNEES DES POINTS DEFINISSANT LA GEOMETRIE C DE LA CONCENTRATION : C - UN SEUL POINT SI ITAB(2) = 1 C - DEUX POINTS SI ITAB(2) = 2 C C EN SORTIE : C TS : TAILLE SOUHAITE POUR L'ELEMENT IT C ELLE EST DONNE PAR LA CONCENTRATION (ITAB,RTAB) C COEF : A * TS / RC (RAYON DU CERCLE CIRCONSCRIT A IT) C "A" EST TEL QUE 0 <= COEF <=1 C PLUS COEF EST PETIT PLUS ON RAFFINE C IERR : CODE D'ERREUR 0 SI OK, C -1 SI TAILLE SOUHAITE EST NEGATIVE C OU SI LE RAYON CIRCONSCRIT EST NUL C C NIVEAU : INTERFACE UTILISATEUR C **************************************************************** REAL COORD(*),TAIREL(*),COEF,TS INTEGER IT,ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX,NBTMAX INTEGER IDIMC,ITAB(*) REAL RTAB(*) INTEGER IERR C INTEGER NUMP1,NUMP2 REAL TAILLE C NUMP1 = ITRNOE((IT-1)*NBNMAX+1) NUMP2 = ITRNOE((IT-1)*NBNMAX+2) IF( NBTMAX.LE.0 )THEN TAILLE = 0.0 CALL D1SUI(COORD((NUMP1-1)*IDIMC+1), > COORD((NUMP2-1)*IDIMC+1), > TAILLE,IDIMC, > ITAB(1),RTAB(2),RTAB(1), > ITAB(2),RTAB(3),COEF,TS,IERR) ELSE CALL D1SUI(COORD((NUMP1-1)*IDIMC+1), > COORD((NUMP2-1)*IDIMC+1), > TAIREL((IT-1)*NBTMAX+1),IDIMC, > ITAB(1),RTAB(2),RTAB(1), > ITAB(2),RTAB(3),COEF,TS,IERR) ENDIF IF( IERR.NE. 0 ) > CALL DSERRE(1,IERR,'D1ISUI','APPEL D1SUI') C 9999 END C C ***************************************************************** C MODULE : M1 (RAFFINE MAILLAGE LINEIQUE) C FICHIER : M1_RAF1D.F C OBJET : RAFFINE UN MAILLAGE LINEIQUE PAR DEFAUT C C FONCT. : C R1ARNO : RAFINE UNE ARETE EN FONCTION DES TAILLES C SOUHAITEES AUX SOMMETS EXTREMITES C R1LIS : REGULARISE LA POSITION D'UN POINT DANS C UN MAILLAGE 1D C C R1NO : RAFFINE UN MAILLAGE 1D PAR LA TAILLE SOUHAITE C AUX NOEUDS C R1RAF : RAFINE PAR DEFAUT UN MAILLAGE LINEIQUE C C AUTEUR : O. STAB C DATE : 03.95 / 06.95 OBSOLET ???? C TESTS : 07.95 C MODIFICATIONS : C AUTEUR, DATE, OBJET : OBSOLET ???? C O.STAB, 30.07.99, AJOUT DE NBRMAX POUR LE MULTI-REFERENCE DANS : C R1NO, R1ARNO, R1RAF C O.STAB, 10.01.05, ajout du cas sommet isole (R1ARNO et R1LIS) C C ***************************************************************** C SUBROUTINE R1NO(ITYPS,RSG, > ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,NOEMAX, > COORD,IDIMC,NBN,NBE,NBPMAX,NBEMAX, C > IMAT,IMATMX,RTVL,NPSMAX,TSN,IERR) > IMAT,NBRMAX,IMATMX, > RTVL,NPSMAX,TSN,IERR) C ********************************************************************** C OBJET R1NO : RAFFINE UN MAILLAGE 1D / LA TAILLE SOUHAITE AUX NOEUDS C C EN ENTREE : C --------- LE MAILLAGE --------------------- C ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,NOEMAX,NBN,NBE : LE MAILLAGE C COORD,IDIMC: LES COORDONNEES DES NOEUDS C NBPMAX : NOMBRE MAXIMUM DE POINTS C NBEMAX : NOMBRE MAXIMUM D'ELEMENTS C IMAT : IMAT((I-1*NBRMAX+K) = REFERENCE K DE L'ELEMENT I C (SI IMATMX > 0) C IMATMX : NOMBRE DE REFERENCES C C ---- DEFINITION DU RAFFINEMENT -------------- C ITYPS : TYPE D'AMORTISSEMENT C RSG : RAISON DE L'AMORTISSEMENT C TSN : TABLEAU DES TAILLES SOUHAITEES AUX NOEUDS C C ---- TABLEAUX DE TRAVAIL -------------------- C RTVL : TABLEAU DE TRAVAIL OU SONT STOQUEES LES COORDONNEES C DES POINTS CALCULES SUR UNE ARETE C NPSMAX : NOMBRE MAXIMUM DE POINTS GENERES SUR UNE ARETE C C C EN SORTIE : LE MAILLAGE MODIFIE C NBE,NBN : LE NOMBRE D'ARETES ET DE NOEUDS APRES GENERATION C IERR : CODE D'ERREUR C 0 SI OK C -1 SI LES DONNEES SONT INCORRECTES C -2 SI LE TABLEAU RTVL EST INSUFFISANT C C ********************************************************************** INTEGER ITYPS REAL RSG INTEGER NBE,NBEMAX,ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX INTEGER IDIMC,NOETRI(*),NOEMAX,NBN,NBPMAX,NPSMAX INTEGER IMAT(*),NBRMAX,IMATMX REAL COORD(*),RTVL(*),TSN(*) INTEGER IERR C INTEGER IO,IE,IT,NBENEW,NBE1 REAL TSIO,TSIE C NBE1 = NBE DO 10 IT=1,NBE1 NBENEW = 0 IO = ITRNOE((IT-1)*NBNMAX+1) IE = ITRNOE((IT-1)*NBNMAX+2) TSIO = TSN( IO ) TSIE = TSN( IE ) CALL R1ARNO(IT,ITYPS,TSIO,TSIE,RSG, > ITRNOE,NBNMAX,ITRTRI,NBCMAX, > NOETRI,NOEMAX, > IMAT,NBRMAX,IMATMX, > COORD,IDIMC,NBN,NBE,NBPMAX,NBEMAX, > RTVL,NPSMAX,NBENEW,IERR) IF( IERR.NE.0 )GOTO 999 10 CONTINUE C 999 END C SUBROUTINE R1ARNO(IT,ITYPS,TSIO,TSIE,RSG, > ITRNOE,NBNMAX,ITRTRI,NBCMAX, > NOETRI,NOEMAX, C > IMAT,IMATMX, > IMAT,NBRMAX,IMATMX, > COORD,IDIMC,NBN,NBE,NBPMAX,NBEMAX, > RTVL,NRTMAX,NBENEW,IERR) C ***************************************************************** C OBJET R1ARNO : RAFINE L'ARETE EN FONCTION DE LA TAILLE SOUHAITE AUX C SOMMETS C EN ENTREE C IT : L'ARETE A RAFFINER C ITYPS : LE TYPE DE LA PROGRESSION (1=GEOM, 2= ARITH) C TSIO : TAILLE SOUHAITE A L'ORIGINE DE L'ARETE C TSIE : TAILLE SOUHAITE A L'EXTREMITE DE L'ARETE C RSG : SI RSG > 1. (GEOM.) OU > 0. (ARITH.) C ON INTERPOLE ENTRE TSIO ET TSIE C AVEC DILATATION SI POSSIBLE C ------------ LE MAILLAGE ----------- C ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,NOEMAX : LE MAILLAGE C NOEMAX : SI = 0 ON NE REMPLI PAS NOETRI SINON = NBPMAX C COORD,IDIMC,NBN : COORDONNEES DES NOEUDS C NBE : LE NOMBRE D'ELEMENTS C NBPMAX : NOMBRE MAXIMUM DE POINTS DANS COORD C NBEMAX : NOMBRE MAXIMUM D'ELEMENTS C IMAT : IMAT((I-1*NBRMAX+K) = REFERENCE K DE L'ELEMENT I C (SI IMATMX > 0) C IMATMX : TAILLE DE IMAT. C C EN SORTIE : LE MAILLAGE MODIFIE C NBENEW : LE NOMBRE D'ARETES GENEREES C IERR : CODE D'ERREUR C 0 SI OK C -1 SI LES DONNEES SONT INCORRECTES C -2 SI LE TABLEAU RTVL EST INSUFFISANT C ***************************************************************** INTEGER IT,NBE,NBEMAX,ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX INTEGER IDIMC,NOETRI(*),NOEMAX INTEGER IMAT(*),NBRMAX,IMATMX INTEGER NBN,NBPMAX,NBENEW,IERR INTEGER ITYPS,NRTMAX REAL RTVL(*),COORD(*),TSIO,TSIE,RSG C INTEGER ITD,IO,IE,I,NBPI,IENEW,INNEW,IDE,K REAL TIT,TSIO2,TSIE2 REAL VSD, TSNUL, XPNUL(3) C C -------------------------- C ---- CALCUL DE LA PROGRESSION ---- C -------------------------- IERR = 0 NBENEW = 0 NBPI = 0 IDE = 1 IO = ITRNOE((IT-1)*NBNMAX+1) IE = ITRNOE((IT-1)*NBNMAX+2) C --- cas des aretes degenere = sommets isoles IF((NBNMAX.LE.1).OR.(IE.EQ.0))GOTO 9999 IF((IE.LE.0 ).OR.(IO.LE.0))THEN IERR = -1 CALL DSERRE(1,IERR,' R1ARNO ','EXTREMITES D ARETE INCORRECTS') ENDIF TSIO2 = TSIO TSIE2 = TSIE C ---------------------- C --- AMORTISSEMENT OU PAS --- C ---------------------- CALL GBARYC(ITRNOE((IT-1)*NBNMAX+1),2,COORD,IDIMC,XPNUL,IERR) CALL GTAILL(ITRNOE((IT-1)*NBNMAX+1),2,IDE,COORD,IDIMC,TIT,IERR) TIT = TIT / 2.0 C CALL SCSUPO(ITYPS,TSIO,RSG, (TIT / 2.0),TSNUL) C CALL SCSUPO(ITYPS,TSIE,RSG, (TIT / 2.0),VSD) C BUG ? POURQUOI REDIVISE T-ON PAR 2 ? CALL SCSUPO(ITYPS,TSIO,RSG, TIT ,TSNUL) CALL SCSUPO(ITYPS,TSIE,RSG, TIT ,VSD) TSNUL = MIN(TSNUL,VSD) IF(( TSNUL.GT.TSIO2 ).AND.(TSNUL.GT.TSIE2))THEN C ---------------------- C --- AMORTISSEMENT DE RSG --- C ---------------------- CALL POSUNM(COORD((IO-1)*IDIMC+1),XPNUL,COORD((IE-1)*IDIMC+1), > IDIMC,TSIO2,TSNUL,TSIE2,ITYPS, > RTVL,NRTMAX,NBPI,IERR) ELSE C ---------------------- C --- PAS D'AMORTISSEMENT --- C ---------------------- CALL POSUM(COORD((IO-1)*IDIMC+1),COORD((IE-1)*IDIMC+1),IDIMC, > TSIO2,TSIE2,ITYPS,RTVL,NRTMAX,NBPI,IERR) ENDIF C IF( IERR.NE. 0 )THEN CALL DSERRE(1,IERR,'R1ARNO','APPEL POSUNM OU POSUM') GOTO 9999 ENDIF C ----------------------- C --- DECOUPAGE DU MAILLAGE --- C ----------------------- NBENEW = NBPI IF( ((NBENEW+NBE).GT.NBEMAX).OR. > ((NBENEW+NBN).GT.NBPMAX) )THEN IERR = -2 CALL DSERRE(1,IERR,'R1ARNO','TROP D ELEMENTS') GO TO 9999 ENDIF C ITD = IT DO 10 I=1,NBPI CALL S0AJNO(RTVL((I-1)*IDIMC+1),COORD,IDIMC,NBN, > NBPMAX,NOETRI,NOEMAX,INNEW,IERR) IF( IERR .NE. 0 )THEN CALL DSERRE(1,IERR,'R1ARNO','APPEL S0AJNO') GOTO 9999 ENDIF CALL S1AJNO(ITD,INNEW,NBE,ITRNOE,NBNMAX,ITRTRI,NBCMAX, > NOETRI,NOEMAX,IENEW,IERR) IF( IERR .NE. 0 )THEN CALL DSERRE(1,IERR,'R1ARNO','APPEL S1AJNO') GOTO 9999 ENDIF C IF( IMATMX.GT.IENEW )IMAT(IENEW) = IMAT(ITD) C REMPLACE PAR : IF( IMATMX.GT.IENEW )THEN DO 5 K=1,NBRMAX IMAT((IENEW-1)*NBRMAX+K) = IMAT((ITD-1)*NBRMAX+K) 5 CONTINUE ENDIF ITD = IENEW 10 CONTINUE C 9999 END C SUBROUTINE R1RAF(ITYPS,RSG, > ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,NOEMAX, > COORD,IDIMC,NBN,NBE,NBPMAX,NBEMAX,NCC, > IMAT,NBRMAX,IMATMX, > RTVL,NRTMAX,ITVL,NITMAX,NCCMAX,IERR) C ***************************************************************** C OBJET R1RAF : RAFINE PAR DEFAUT UN MAILLAGE LINEIQUE C APPEL DENS1DDEF POUR LA DEFINITION DES DENSITES C APPEL R1NO POUR LE DECOUPAGE C EN ENTREE: C ------------ LE MAILLAGE ----------- C ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,NOEMAX : LE MAILLAGE C NOEMAX : SI = 0 ON NE REMPLI PAS NOETRI SINON = NBPMAX C COORD,IDIMC,NBN : COORDONNEES DES NOEUDS C NBE : LE NOMBRE D'ELEMENTS C NCC : LE NOMBRE DE COMPOSANTES CONNEXES C = 0 SI INCONNU. C NBPMAX : NOMBRE MAXIMUM DE POINTS DANS COORD C NBEMAX : NOMBRE MAXIMUM D'ELEMENTS C --------- LES REGIONS --------------------- C IMAT : SI IMATMX == 0, PAS DE DEFINITION DE REGION C SI IMATMX == 1, UNE SEULE REGION C : IMAT((I-1*NBRMAX+K) = REFERENCE K DE L'ELEMENT I C (SI IMATMX > 0) C IMATMX : TAILLE DE IMAT = 0,1, OU NBEMAX C C --- TABLEAU DE TRAVAIL --------------------- C ITVL : TABLEAU DE TRAVAIL OU SONT STOQUEES LES C DIFFERENTES COMPOSANTES CONNEXES. C NITMAX : TAILLE DE ITVL C SI NCC = 1 ITVL NE SERT A RIEN C AU MINIMUM = NBCCMAX + 2*NBE + 3 C AU MAXIMUM = NBCCMAX + 2*NBE + 3*NBE C NCCMAX : NOMBRE MAXIMUM DE COMPOSANTES CONNEXES C RTVL : TABLEAU DE TRAVAIL OU SONT STOQUEES LES COORDONNEES C DES POINTS CALCULES SUR UNE ARETE C NPSMAX : NOMBRE MAXIMUM DE POINTS GENERES SUR UNE ARETE C ---- DEFINITION DU RAFFINEMENT -------------- C ITYPS : TYPE D'AMORTISSEMENT C RSG : RAISON DE L'AMORTISSEMENT C C EN SORTIE: LE MAILLAGE MODIFIE C ----------- C NBN : NOMBRE DE NOEUDS APRES LE RAFFINEMENT C NBE : " D'ELEMENTS APRES " " " C IERR : CODE D'ERREUR 0 SI OK C -1 SI LES DONNEES SONT INCORRECTES C -2 SI ITVL OU RTVL EST TROP PETIT C C REMARQUES IMPORTANTES : C ----------------------- C EN ENTREE LE MAILLAGE PEUT ETRE : C - COMPOSE DE PLUSIEURS COMPOSANTES CONNEXES ; C - COMPOSE DE CHAINES FERMEES OU OUVERTES ; C - COMPOSE D'ARETES DANS UN ESPACE DE DIMENSION 1, 2 OU 3. C PAR CONTRE : C - UN NOEUD NE DOIT APPARTENIR QU'A UNE OU DEUX ARETES ; C - L'EPAISSEUR DU DOMAINE N'EST PAS PRISE EN COMPTE ; C ***************************************************************** INTEGER ITYPS REAL RSG INTEGER ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX,NOETRI(*),NOEMAX INTEGER IMAT(*),NBRMAX,IMATMX REAL COORD(*) INTEGER IDIMC,NBN,NBE,NBPMAX,NBEMAX,NCC REAL RTVL(*) INTEGER NRTMAX,ITVL(*),NITMAX,NCCMAX,IERR C INTEGER ITSN,NTSMAX,IPT,NPSMAX C =================================== C --- 1. CALCUL DES DENSITES PAR DEFAUT --- C =================================== ITSN = 1 NTSMAX = NRTMAX CALL D1DSLN(ITYPS,RSG, > ITRNOE,NBNMAX,COORD,IDIMC,NBE, > RTVL(ITSN),NTSMAX,IERR) C --- PLUS BESOIN DE LA STRUCTURE EN 2.0.0 C CALL D1DS(ITYPS,RSG, C > ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,NOEMAX, C > COORD,IDIMC,NBN,NBE,NBPMAX,NBEMAX,NCC, C > ITVL,NITMAX,NCCMAX,RTVL(ITSN),NTSMAX,IERR) IF( IERR.NE.0 )THEN CALL DSERRE(1,IERR,'R1RAF','APPEL D1DSLN') GOTO 9999 ENDIF C =================================== C --- 2. CALCUL DES NOEUDS --- C =================================== IPT = NBN + ITSN NPSMAX = NRTMAX - IPT CALL R1NO(ITYPS,RSG, > ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,NOEMAX, > COORD,IDIMC,NBN,NBE,NBPMAX,NBEMAX, C > IMAT,IMATMX, > IMAT,NBRMAX,IMATMX, > RTVL(IPT),NPSMAX,RTVL(ITSN),IERR) C IF( IERR.NE.0 )THEN CALL DSERRE(1,IERR,'R1RAF','APPEL R1NO') GOTO 9999 ENDIF 9999 END C C SUBROUTINE R1LIS(NUMP,ITYPS,RSG, > ITRNOE,NBNMAX,ITRTRI,NBCMAX, > NOETRI,COORD,IDIMC,DEPLAC,IERR) C ***************************************************************** C OBJET R1LIS : REGULARISE LA POSITION D'UN POINT DANS UN MAILLAGE 1D C EN ENTREE : C NUMP : LE NUMERO DU POINT A REGULARISER C COORD : TABLEAU DES COORDONNEES DES POINTS C IDIMC : DIMENSION DE L'ESPACE C ITYPS : TYPE DE LA SUITE C RSG : RAISON DE LA SUITE C ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI : LE MAILLAGE C EN SORTIE : C DEPLAC : NORME DU DEPLACEMENT RELATIF C IERR : -1 SI ERREUR 0 SI OK C ***************************************************************** INTEGER NUMP,ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX,NOETRI(*) INTEGER IDIMC,IERR,ITYPS REAL COORD(*),RSG,DEPLAC C INTEGER IT2,IT,NUMP1,NUMP3 REAL XPN(3) C IERR =0 DEPLAC = 0.0 C --- cas des aretes degenere = sommets isoles IF(NBNMAX.LE.1)GOTO 9999 IT = NOETRI(NUMP) IF( IT.LE.0 )THEN IERR = -1 CALL DSERRE(1,IERR,'R1LIS',' STRUCTURE NOETRI INEXISTANTE') IERR = 0 CALL DSERRE(1,IERR,'R1LIS',' SOMMET ISOLE') GOTO 9999 ENDIF NUMP1 = ITRNOE((IT-1)*NBNMAX+1) IF( NUMP1.EQ.NUMP )THEN C --- NUMP EST L'ORIGINE DE IT --- IT2 = ITRTRI((IT-1)*NBCMAX+1) IF( IT2.LE.0 )THEN IERR = -1 CALL DSERRE(1,IERR,'R1LIS',' STRUCTURE ITRTRI INEXISTANTE') GOTO 9999 ENDIF NUMP1 = ITRNOE((IT2-1)*NBNMAX+1) NUMP3 = ITRNOE((IT-1)*NBNMAX+2) ELSE C --- NUMP EST L'EXTREMITE DE IT --- IT2 = ITRTRI((IT-1)*NBCMAX+2) IF( IT2.LE.0 )THEN IERR = -1 CALL DSERRE(1,IERR,'R1LIS',' STRUCTURE ITRTRI INEXISTANTE') GOTO 9999 ENDIF NUMP3 = ITRNOE((IT2-1)*NBNMAX+2) NUMP1 = ITRNOE((IT-1)*NBNMAX+1) ENDIF C IF((NUMP1.LE.0 ).OR.(NUMP3.LE.0))THEN IERR = -1 CALL DSERRE(1,IERR,' R1LIS ','EXTREMITES D ARETE INCORRECTS') ENDIF C CALL LISUPO(COORD((NUMP1-1)*IDIMC+1),COORD((NUMP-1)*IDIMC+1), > COORD((NUMP3-1)*IDIMC+1),IDIMC,ITYPS,RSG,XPN,DEPLAC,IERR) IF( IERR .NE. 0 )THEN CALL DSERRE(1,IERR,'R1LIS',' APPEL LISUPO') GOTO 9999 ENDIF IF(DEPLAC.GT.0.0)CALL COPIVE(XPN,IDIMC,COORD((NUMP-1)*IDIMC+1)) 9999 END C C C ********************************************************************** C MODULE : C FICHIER : RF_RAF1D.F (RF_RAF3D.F) C OBJET : RAFFINEMENT DES SEGMENTS C FONCT. : C R1DIR : RAFINE DIRECTEMENT UNE ARETE DU MAILLAGE C R1RECH : RECHERCHE DE L'ELEMENT A RAFINER (ITERATIF) (LOCAL) C R1ITER : RAFFINE ITERATIVEMENT UN MAILLAGE EN SEGMENTS C R1RAFF : RAFFINE UN MAILLAGE EN SEGMENTS 2D/3D C C AUTEUR : O. STAB C DATE : 15.06.98 C TESTS : C MODIFICATIONS : C AUTEUR, DATE, OBJET : C O.STAB, 30.07.99, AJOUT DE NBRMAX POUR LE MULTI-REFERENCE DANS : C R1DIR, R1ITER, R1RAFF C O.STAB, 25.09.2003, AJOUT WARNING MODGEN != 1 (DANS R1RAFF) C O.STAB, 02.02.2005, bug dans R1DIR limitation des noeuds C C ********************************************************************** C SUBROUTINE R1DIR(MODDEF,IARD,FADEC,ITAB,RTAB, > ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,NOEMAX, > ITBREG,NBRMAX,IRGMAX, > COORD,IDIMC,NBN,NBE,NBPMAX,NBEMAX, > RTVL,IRMAX,NBENEW,IERR) C ***************************************************************** C OBJET R1DIR : RAFINE DIRECTEMENT UNE ARETE DU MAILLAGE C EN ENTREE C MODDEF : IL Y A 3 MODES DE FONCTIONNEMENT C (1) LE MODE DEFAUT SIMPLE C (2) LE MODE CONCENTRATIONS(X,Y) C (3) LE MODE VALEURS NODALES C --------- LE DECOUPAGE ------------------- C IARD : NUMERO DE L'ARETE A DECOUPER C FADEC : INUTILISE C ITAB : PARAMETRES ENTIERS DE LA FONCTION FADEC C RTAB : PARAMETRES REELS DE LA FONCTION FADEC C C RTVL : TABLEAU DE TRAVAIL TAILLE NECESSAIRE = NOMBRE MAX. C DE NOEUDS RENVOYES PAR FADEC C IRMAX : TAILLE MAX. DE RTVL C --------- LE MAILLAGE --------------------- C ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,NOEMAX,NBN,NBE : LE MAILLAGE C COORD,IDIMC: LES COORDONNEES DES NOEUDS C NBPMAX : NOMBRE MAXIMUM DE POINTS C NBEMAX : NOMBRE MAXIMUM D'ELEMENTS C ITBREG : ITBREG((I-1)*NBRMAX+K) = REFERENCE K DE L'ELEMENT I C IRGMAX : TAILLE DE ITBREG C C EN SORTIE : LE MAILLAGE MODIFIE C NBENEW : LE NOMBRE D'ARETES GENEREES C IERR : CODE D'ERREUR C 0 SI OK C 1 SI ON A PAS PU GENERER TOUS LES POINTS ! C -1 SI LES DONNEES SONT INCORRECTES C -2 SI LE TABLEAU RTVL EST INSUFFISANT C C REMARQUE : POUR RETROUVER TOUS LES ELEMENTS ET NOEUDS GENERES C IL SUFFIT DE REPARTIR DE IARD ET DE PARCOURIR LES C NBENEW ARETES SUIVANTES C C MODIFICATION : C O.STAB, 30.07.99, AJOUT DE NRGMAX POUR LE MULTI-REFERENCE C O.STAB, 10.01.05, RETOUR POUR LES ARETES DEGENEREES (SOMMETS ISOLES) C ***************************************************************** INTEGER MODDEF INTEGER IARD,ITAB(*) REAL RTAB(*) INTEGER NBRMAX INTEGER NBE,NBEMAX,ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX INTEGER IDIMC,NOETRI(*),NOEMAX, ITBREG(*),IRGMAX INTEGER NBN,NBPMAX,IRMAX,NBENEW,IERR REAL COORD(*),RTVL(*) C INTEGER IE,IORIG,IEXTR,NIAD,I,K,INNEW,IENEW REAL TS1,TS2,V1(3),S12,RSGCAL INTEGER ITYPS REAL XNORVE EXTERNAL FADEC,XNORVE C NBENEW = 0 IE = IARD IORIG = ITRNOE((IE-1)*NBNMAX+1) IEXTR = ITRNOE((IE-1)*NBNMAX+2) C --- Ajout 10.01.2005, pour les aretes degeneree : IF((IORIG.EQ.IEXTR).OR.(IEXTR.EQ.0))GOTO 9999 C ===================================== C ---- CALCUL DES POINTS SUR LE SEGMENT --------------------- C ===================================== GOTO (10,20,30) MODDEF C --------------------------- C --- DEFINITION DE TYPE INCONNUE --- C --------------------------- IERR = -1 GOTO 9999 C --------------------------------------------- C --- DEFINITION PAR DEFAUT (C'EST UNE ERREUR ICI) --- C --------------------------------------------- 10 CONTINUE IERR = -1 GOTO 9999 C ----------------------------- C --- DEFINITION FONCTION SPATIALE --- C ----------------------------- 20 CONTINUE C CALL D1SU(COORD((IORIG-1)*IDIMC+1),COORD((IEXTR-1)*IDIMC+1),IDIMC, CALL D1SU2(COORD((IORIG-1)*IDIMC+1), > COORD((IEXTR-1)*IDIMC+1),IDIMC, > ITAB(1),RTAB(2),RTAB(1),ITAB(2),RTAB(3), C > ITYPS, TSP, RSG, ITYPO, ROBJET, C > RTVL((I-1)*IDIMC+1),NBPMAX,NIAD,IERR) > RTVL,(IRMAX/IDIMC),NIAD,IERR) GOTO 40 C ------------------------------- C --- DEFINITION VALEURS AUX NOEUDS --- C ------------------------------- 30 CONTINUE C LA TAILLE SOUHAITEE EST DONNEE AUX NOEUDS. C ON CALCULE LES POINTS RESPECTANT SUIVANT UNE SUITE GEOMETRIQUE TS1 = RTAB(IORIG) TS2 = RTAB(IEXTR) ITYPS = 1 C ---- COPIE DE POSUM ---- CALL DIFFVE(COORD((IEXTR-1)*IDIMC+1), > COORD((IORIG-1)*IDIMC+1),IDIMC,V1) S12 = XNORVE(V1,IDIMC) CALL SU2PO(ITYPS,S12,TS1,TS2,NIAD,RSGCAL,IERR) IF( IERR .NE. 0 )GOTO 8888 IF( NIAD .LE. 0 )THEN NIAD = 0 GOTO 40 ENDIF C --- RECALALGE DES VALEURS TS1, TS2 --- CALL SCSUSE(ITYPS,S12,NIAD,RSGCAL,TS1,TS2,IERR) IF( IERR .NE. 0 )GOTO 8888 IF( NIAD .GT. NBPMAX )THEN IERR = -2 CALL DSERRE(1,IERR,'R1DIR','TROP DE POINTS') GO TO 9999 ENDIF S12 = 1.0 / S12 CALL MUSCVE(V1,S12,IDIMC,V1) CALL SUPTSU(COORD((IORIG-1)*IDIMC+1), > V1,IDIMC,ITYPS,TS1,NIAD,RSGCAL, c > RTVL((I-1)*IDIMC+1),IERR) > RTVL,IERR) C ---- FIN DE LA COPIE DE POSUM ---- C CALL POSUM(COORD((IORIG-1)*IDIMC+1), C > COORD((IEXTR-1)*IDIMC+1),IDIMC, C > TS1,TS2,ITYPS,RTVL((I-1)*IDIMC+1),NBPMAX,NIAD,IERR) GOTO 40 C 40 CONTINUE IF( IERR.NE.0)THEN CALL DSERRE(1,IERR,'R1DIR','APPEL POSUM OU D1SU') GOTO 9999 ENDIF IF( NIAD .EQ. 0 )GOTO 9999 C ===================================== C ---- INSERTION DANS LE MAILLAGE LINEIQUE --------------------- C ===================================== NBENEW = MIN(NIAD,NBPMAX-NBN) IE = IARD DO 50 I=1,NBENEW CALL S0AJNO(RTVL((I-1)*IDIMC+1),COORD,IDIMC,NBN, > NBPMAX,NOETRI,NOEMAX,INNEW,IERR) IF( IERR .NE. 0 )GOTO 8888 CALL S1AJNO(IE,INNEW,NBE,ITRNOE,NBNMAX,ITRTRI,NBCMAX, > NOETRI,NOEMAX,IENEW,IERR) IF( IERR .NE. 0 )GOTO 8888 C --- LA TAILLE SOUHAITEE AU NOUVEAU NOEUD --- C (ELLE EST DONNE PAR LA SUITE GEOMETRIQUE) IF( MODDEF.EQ.3 )THEN CALL DIFFVE(COORD((INNEW-1)*IDIMC+1), > COORD((IORIG-1)*IDIMC+1),IDIMC,V1) S12 = XNORVE(V1,IDIMC) CALL SCSUPO(ITYPS,TS1,RSGCAL,S12,TS2) RTAB(INNEW) = TS2 ENDIF C --- HERITAGE DES MATERIAUX --- C IF( IENEW.LE.IRGMAX )ITBREG( IENEW ) = ITBREG( IARD ) C REMPLACE PAR : O.STAB, 30.07.99 POUR LE MULTI-REFERENCES C --- HERITAGE DES REFERENCES --- IF( IENEW.LE.IRGMAX )THEN DO 45 K=1,NBRMAX ITBREG((IENEW-1)*NBRMAX+K) = ITBREG((IARD-1)*NBRMAX+K) 45 CONTINUE ENDIF C --- FIN MODIF IE = IENEW 50 CONTINUE C --- ON A PAS PU GENERER TOUS LES POINTS --- C IF((NIAD+NBN).GT.NBPMAX)THEN --> bug 02.02.2005 NBN est incremente dans S0AJNO IF(NIAD.GT.NBENEW)THEN IERR = 1 GOTO 9999 ENDIF C 8888 IF( IERR .NE. 0 )CALL DSERRE(1,IERR,'R1DIR','ERREUR EN SORTIE') 9999 END C C SUBROUTINE R1RECH(IDIMC,ITRNOE,NBNMAX,NBE,COORD,TBCOEF, > NBTMAX,IT,XPT,COEF,IERR) C ********************************************************************** C OBJET R1RECH : CHERCHE L'ELEMENT LINEIQUE A RAFFINER (ITERATIF) (LOCAL) C EN ENTREE : C COORD : COORDONNEES DES POINTS C IDIMC : DIMENSION DE L'ESPACE C ITRNOE,NBNMAX : SOMMETS DES ELEMENTS C NBE : NOMBRE D'ELEMENTS C TBCOEF : TABLEAU DES COEFICIENTS DE RAFFINEMENT C NBTMAX : INUTILISE (GARDE LA SIGNATURE DE RFRECH) C C EN SORTIE : C IT : L'ELEMENT A REFFINER C XPT : LE POINT A AJOUTER C COEF : LA VALEUR DU RAFFINEMENT [0-1] C PLUS COEF EST PETIT PLUS ON RAFFINE C IERR : CODE D'ERREUR (INUTILISE) C ********************************************************************** REAL COORD(*),TBCOEF(*) INTEGER IDIMC,ITRNOE(*),NBNMAX,NBE,NBTMAX,IT,IERR REAL COEF,XPT(*) C INTEGER I,NUMP1,NUMP2 REAL LRCMIN,XDEMI C LRCMIN = 1.0 XDEMI = 0.5 IT = 0 C --- RECHERCHE DU PLUS PETIT COEF = TS/TR --- DO 10 I=1,NBE IF( TBCOEF(I) .LT. LRCMIN )THEN IT = I LRCMIN = TBCOEF(I) ENDIF 10 CONTINUE C IF( IT.EQ. 0 )THEN COEF = 1. GOTO 9999 ENDIF C --- MILIEU DU SEGMENT ------------------ NUMP1 = ITRNOE((IT-1)*NBNMAX+1) NUMP2 = ITRNOE((IT-1)*NBNMAX+2) CALL SOMMVE(COORD((NUMP1-1)*IDIMC+1), > COORD((NUMP2-1)*IDIMC+1),IDIMC,XPT) CALL MUSCVE(XPT,XDEMI,IDIMC,XPT) C COEF = LRCMIN 9999 END C SUBROUTINE R1ITER(FADEC,ITAB,RTAB,MODDEF, > ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,NOEMAX, > ITBREG,NBRMAX,NMT, > COORD,IDIMC,NBN,NBE,NBPMAX,NBEMAX, > ITVL,IMAX,RTVL,IRMAX,NBENEW,IERR) C ***************************************************************** C OBJET R1ITER : RAFFINE ITERATIVEMENT UN MAILLAGE LINEIQUE (APPEL FADEC) C EN ENTREE C --------- LE DECOUPAGE ------------------- C FADEC : FONCTION D'EVALUATION DU DECOUPAGE ET DE C CALCUL D'UN NOEUD, ELLE A LE FORMAT SUIVANT : C C FADEC(IT,ITRNOE,NBNMAX,ITRTRI,NBCMAX, C COORD,IDIMC,TBCOEF,NBTMAX,ITAB,RTAB,COEF,TS,IERR) C CF. D2IDEF C C ITAB : PARAMETRES ENTIERS DE LA FONCTION FADEC C RTAB : PARAMETRES REELS DE LA FONCTION FADEC C MODDEF : IL Y A 3 MODES DE FONCTIONNEMENT C (1) LE MODE DEFAUT SIMPLE C (2) LE MODE CONCENTRATIONS(X,Y) C (3) LE MODE VALEURS NODALES C C --------- TABLEAUX DE TRAVAIL ------------------- C ITVL : TABLEAU DE TRAVAIL (???) C IMAX : TAILLE DU TABLEAU DE TRAVAIL C RTVL : TABLEAU DE TRAVAIL COORDONNEES + TBCOEFERES C IRMAX : TAILLE DE RTVL >= ??? C --------- LE MAILLAGE --------------------- C ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,NOEMAX,NBN,NBE : LE MAILLAGE C COORD,IDIMC: LES COORDONNEES DES NOEUDS C NBPMAX : NOMBRE MAXIMUM DE POINTS C NBEMAX : NOMBRE MAXIMUM D'ELEMENTS C --------- LES REGIONS --------------------- C ITBREG : SI NMT == 0, PAS DE DEFINITION DE REGION C SI NMT == 1, UNE SEULE REGION C SI NMT > 1, ITBREG((I-1)*NBRMAX) = REGION K DE L'ELEMENT I C MNT : TAILLE DE ITBREG = 0,1*NBRMAX, OU NBEMAX*NBRMAX C C EN SORTIE : LE MAILLAGE MODIFIE C NBN : LE NOMBRE DE NOEUDS = NBP + NBPNEW C NBE : LE NOMBRE D'ELEMENTS = NBPNEW + NBE C NBENEW : LE NOMBRE D'ELEMENTS GENEREES = NBPNEW C IERR : CODE D'ERREUR C 2 LE NOMBRE D'ELEMENTS MAXIMUM EST ATTEINT (MEMOIRE) C 1 LE NOMBRE DE NOEUDS MAXIMUM (DONNE) EST ATTEINT C 0 LA TAILLE SOUHAITEE EST ATTEINTE C -1 TOUS LES POINTS N'ONT PAS PU ETRE AJOUTES C -2 ITVL OU RTVL TROP PETIT C REMARQUES : C NBPNEW : LE NOMBRE DE NOEUDS GENERES = NBENEW / 2 C ********************************************************************** INTEGER ITAB(*),MODDEF REAL RTAB(*) INTEGER NBE,NBEMAX,ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX INTEGER ITVL(*),IMAX INTEGER IDIMC,NOETRI(*),NOEMAX,NBN,NBPMAX,IRMAX,NBENEW,IERR INTEGER ITBREG(*),NBRMAX,NMT REAL COORD(*),RTVL(*) EXTERNAL FADEC C C --- POUR LES STATS --- REAL ZEROTR PARAMETER ( ZEROTR = 1.E-30 ) C --- VARIABLES INTERNES --- REAL XPT(3) INTEGER IDE,NCOORD,I,IPT,ITCOEF,ICOORD,IT,IPTNEW,IENEW,K REAL COEF,TS,RTVNUL(1) INTEGER NBTMAX,NBTNEW,ITRACE,NBRMX2 REAL COEFMX C --- RAPPORT MINI COEFMX = TS/TR = 1/1.5 --- DATA COEFMX/0.66666666666666666666/ C C ==================================== C C ===== INITIALISATION ===== C C ==================================== C C TEST DES ENTREES C NORMALISATION DES POINTS (PTINIT) C TRI DES ELEMENTS A RAFFINER C NBENEW = 0 ITRACE = 1 C --- ON STOQUE LE COEFFICIENT DES ELEMENTS ---- NBTMAX = 1 C --- MAIS PAS LA TAILLE DES SEGMENTS --- NBRMX2 = 0 IERR = 0 IPTNEW = 0 IDE = 1 NCOORD = NBN C C LE NOMBRE MAXIMUM DE NOEUDS DONNE PAR L'UTILISATEUR EST ATTEINT C IF( NBN.EQ.NBPMAX )THEN IERR = 1 GOTO 9999 ENDIF C IF((NBN.EQ.0).OR.(IDIMC.LT. 1).OR.(IDIMC.GT. 3))THEN IERR = -1 CALL DSERRE(1,IERR,'R1ITER',' DONNEES INCORRECTES ') C PRINT *,'NBN,IDIMC = ',NBN,IDIMC GOTO 9999 ENDIF IF(NBNMAX.LT.IDE)THEN IERR = -1 CALL DSERRE(1,IERR,'R1ITER',' DONNEES INCOMPATIBLES ') C PRINT *,'NBNMAX,NBCMAX,IDE = ',NBNMAX,NBCMAX,IDE GOTO 9999 ENDIF C ICOORD = 1 ITCOEF = (IDIMC * NBPMAX) + ICOORD C IF( (IRMAX-ITCOEF).LT.NBPMAX)THEN C MODIF 25.09.2003 : memoire mal evaluee : IF( (IRMAX-(ITCOEF-1)).LT.(NBPMAX+NBE*NBTMAX))THEN IERR = -2 CALL DSERRE(1,IERR,'R1ITER',' TABLEAU DES REELS ') GOTO 9999 ENDIF C CALL PTINIT(COORD,IDIMC,NBN,ZEROTR,RTVL(ICOORD),IERR) C --- ON NE NORMALISE PAS POUR POUVOIR DEBUGGER --- CALL COPIVE(COORD,(NBN*IDIMC),RTVL(ICOORD)) C ---------------------------------------------------- C --- CALCUL DES COEFICIENTS DES ELEMENTS ------ C ---------------------------------------------------- DO 20 I=1,NBE RTVL((I-1)*NBTMAX+ITCOEF) = 0.0 CALL FADEC(I,ITRNOE,NBNMAX,ITRTRI,NBCMAX, > RTVL(ICOORD),IDIMC,RTVNUL,NBRMX2, > ITAB,RTAB,COEF,TS,IERR) IF( IERR .NE. 0 )THEN CALL DSERRE(1,IERR,'R1ITER', > 'APPEL FADEC (CALCUL DE LA TAILLE SOUHAITE)') GOTO 9999 ENDIF RTVL(I-1+ITCOEF) = COEF 20 CONTINUE C IPT = NBN C C ==================================== C C ===== BOUCLE SUR LES ELEMENTS A RAFFINER ===== C C ==================================== C 30 CONTINUE IERR = 0 C ------------------ C ---- CHOIX DE L'ELEMENT ---------------------- C ------------------ CALL R1RECH(IDIMC,ITRNOE,NBNMAX, > NBE,RTVL(ICOORD),RTVL(ITCOEF), > NBTMAX,IT,XPT,COEF,IERR) C IF( IERR .NE. 0 )THEN CALL DSERRE(1,IERR,'R1ITER','APPEL R1RECH') GOTO 9999 ENDIF C IF( ITRACE.NE.0 ) C > PRINT *,' IT =',IT,' 2*L/RC =',COEF,' XPT = ',(XPT(J),J=1,IDIMC) C ------------------------------------------------ C ---- SORTIE DE BOUCLE : PLUS D'ELEMENTS A RAFFINER --- C ------------------------------------------------ IF((IT.EQ.0).OR.(COEF.GT.COEFMX))THEN C --- ON NE NORMALISE PAS POUR POUVOIR DEBUGGER --- IERR = 0 C PRINT *,'NOMBRE DE NOEUD GENERES = ',NBN - NCOORD C PRINT *,'NOMBRE DE NOEUD TESTES = ',IPT - NCOORD GOTO 8888 ENDIF C ---------------------------------------------------- C --- TAILLE MINI. DES NOUVEAUX ELEMENTS ------ C ---------------------------------------------------- CALL FADEC(IT,ITRNOE,NBNMAX,ITRTRI,NBCMAX, > RTVL(ICOORD),IDIMC,RTVNUL,NBRMX2, > ITAB,RTAB,COEF,TS,IERR) IF( IERR.NE.0 )THEN CALL DSERRE(1,IERR,'R1ITER','APPEL FADEC ') GOTO 9999 ENDIF C ---------------------------------------------------- C ---- INSERTION DANS LE MAILLAGE LINEIQUE ------ C ---------------------------------------------------- IF(NBN+1.GT.NBPMAX)THEN C --- ON A ATTEIND LA LIMITE DONNEE PAR L'UTILISATEUR --- IERR = 1 GOTO 8888 ENDIF C --- AJOUT DU NOEUD --- IPT = IPT + 1 CALL S0AJNO(XPT,RTVL(ICOORD),IDIMC,NBN,NBPMAX, > NOETRI,NOEMAX,IPTNEW,IERR) IF( IERR.NE.0 )THEN CALL DSERRE(1,IERR,'R1ITER','APPEL S0AJNO') ENDIF CALL S1AJNO(IT,IPTNEW,NBE,ITRNOE,NBNMAX,ITRTRI,NBCMAX, > NOETRI,NOEMAX,IENEW,IERR) C IF( IERR.NE.0 )THEN CALL DSERRE(1,IERR,'R1ITER','APPEL ARAJPO ') GOTO 9999 ENDIF C --- L'ELEMENT NE PEUT PAS ETRE RAFFINE --- C ---------------------------------------------------- C --- MISE A JOUR DES COEFICIENTS DES NOUVEAUX ELEMENTS ------ C ---------------------------------------------------- C AJOUT D'UNE LIGNE POUR LA MISE A JOUR DES CHAMPS POINTS IF(MODDEF.EQ.3)RTAB(IPTNEW) = TS NBENEW = NBENEW + NBTNEW CALL FADEC(IENEW,ITRNOE,NBNMAX,ITRTRI,NBCMAX, > RTVL(ICOORD),IDIMC,RTVNUL,NBRMX2, > ITAB,RTAB,COEF,TS,IERR) IF( IERR.NE.0 )THEN CALL DSERRE(1,IERR,'R1ITER','APPEL FADEC ') GOTO 9999 ENDIF RTVL((IENEW-1)*NBTMAX+ITCOEF) = COEF CALL FADEC(IT,ITRNOE,NBNMAX,ITRTRI,NBCMAX, > RTVL(ICOORD),IDIMC,RTVNUL,NBRMX2, > ITAB,RTAB,COEF,TS,IERR) IF( IERR.NE.0 )THEN CALL DSERRE(1,IERR,'R1ITER','APPEL FADEC ') GOTO 9999 ENDIF RTVL((IT-1)*NBTMAX+ITCOEF) = COEF C --- MISE A JOUR DES REGIONS --- C IF( NMT.GT.1)ITBREG(IENEW) = ITBREG(IT) C REMPLACE PAR : O.STAB, 30.07.99 IF( NMT.GT.1)THEN DO 100 K=1,NBRMAX ITBREG((IENEW-1)*NBRMAX+K) = ITBREG((IT-1)*NBRMAX+K) 100 CONTINUE ENDIF IF( IPTNEW .LT. NBPMAX )GO TO 30 C C ==================================== C C ===== FIN ===== C C ==================================== C C PRINT *,' NOMBRE MAXIMUM DE NOEUDS GENERES',IPTNEW C --- ON NE NORMALISE PAS POUR POUVOIR DEBUGGER --- IERR = 1 C 8888 CONTINUE CALL COPIVE(RTVL,(NBN*IDIMC),COORD) C 9999 END C C C SUBROUTINE R1RAFF(MODDEF,MODGEN, > ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,NOEMAX, > ITBREG,NBRMAX,NMT, > COORD,IDIMC,NBN,NBE,NBPMAX,NBEMAX, > FADEC,ITAB,NIADEC,RTAB,IRADEC,NFADEC, > ITVL,NITMAX,RTVL,NRTMAX,IERR) C ********************************************************************** C OBJET R1RAFF : RAFFINE UN MAILLAGE LINEIQUE (APPELS R1DIR ET R1ITER) C C EN ENTREE : C MODDEF : IL Y A 3 TYPES DE DEFINITIONS C 1 LE MODE DEFAUT SIMPLE C 2 LE MODE CONCENTRATIONS(X,Y) C 3 LE MODE VALEURS NODALES C MODGEN : IL Y A 3 MODES DE GENERATION C 1 LE MODE DIRECT C 2 LE MODE ITERATIF C 3 LE MODE ITERATIF + LISSAGE C C --------- LE MAILLAGE --------------------- C ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,NOEMAX,NBN,NBE : LE MAILLAGE C COORD,IDIMC: LES COORDONNEES DES NOEUDS C NBPMAX : NOMBRE MAXIMUM DE POINTS C NBEMAX : NOMBRE MAXIMUM D'ELEMENTS C C ---- DEFINITION DU RAFFINEMENT -------------- C FADEC : C ITAB((I-1)*NIADEC+1) : PARAMETRES ENTIERS DU IEME RAFFINEMENT C NIADEC : NOMBRE MAX. DE PARAMETRES ENTIERS C RTAB((I-1)*NIADEC+1) : PARAMETRES REELS DU IEME RAFFINEMENT C IRADEC : NOMBRE MAX. DE PARAMETRES REELS C NFADEC : NOMBRE DE RAFFINEMENTS C C --------- LES REGIONS --------------------- C ITBREG : SI NMT == 0, PAS DE DEFINITION DE REGION C SI NMT == 1, UNE SEULE REGION C SI NMT > 1, ITBREG((I-1)*NBRMAX+K) = REGION K DE L'ELEMENT I C MNT : TAILLE DE ITBREG = 0,1*NBRMAX, OU NBEMAX*NBRMAX C C ---- TABLEAUX DE TRAVAIL -------------------- C ITVL : SERT POUR TAJPOT C NITMAX : TAILLE DE (6*NBADET+10) (CF. TAJPOT) C RTVL : TABLEAU DE REELS POUR LES CALCULS C NRTMAX : TAILLE DE RTVL (8*NBNPMAX+244) C C EN SORTIE : LE MAILLAGE MODIFIE C NBE,NBN : LE NOMBRE DE TRIANGLES ET DE NOEUDS APRES GENERATION C IERR : C MAILLAGE CORRECT C 2 LE NOMBRE D'ELEMENTS MAXIMUM EST ATTEINT (MEMOIRE) C 1 LE NOMBRE DE NOEUDS MAXIMUM (DONNE) EST ATTEINT C 0 OK C MAILLAGE INCORRECT C -1 SI DONNEES INCORRECTES C -2 SI TABLEAUX INSUFFISANTS C C MODIFICATION : O.STAB, 25.09.2003, AJOUT WARNING MODGEN != 1 C ********************************************************************** INTEGER MODDEF,MODGEN INTEGER NBE,NBEMAX,ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX INTEGER NOETRI(*),NOEMAX,NBN,NBPMAX INTEGER ITBREG(*),NBRMAX,NMT REAL COORD(*) INTEGER IDIMC,ITAB(*),NFADEC,NIADEC,IRADEC INTEGER ITVL(*) REAL RTAB(*),RTVL(*) INTEGER NITMAX,NRTMAX,IERR EXTERNAL FADEC C INTEGER NBENEW,I,J,NBE1,NBN1,ITYPS REAL RSGMAX,DP1MAX,DP2MAX,DEPLAC,DP3MAX,DPAMAX C IERR = 0 NBENEW = 0 C *** ajout 25.09.2003 *** IF( MODGEN.NE.1)THEN CALL DSERRE(1,IERR,'R1RAFF',' ATTENTION MODE 2 ou 3 ') ENDIF C *** fin ajout *** GOTO (300,400,400) MODGEN IERR = -1 GOTO 9999 C ===================================== C --- 1. RAFFINEMENT DIRECT --- C ===================================== 300 CONTINUE DO 320 I=1,NFADEC NBE1 = NBE C WRITE(*,*) 'RAFIN = ',I DO 310 J=1,NBE1 CALL R1DIR(MODDEF,J,FADEC, > ITAB((I-1)*NIADEC+1),RTAB((I-1)*IRADEC+1), > ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,NOEMAX, C > ITBREG,NMT, > ITBREG,NBRMAX,NMT, > COORD,IDIMC,NBN,NBE,NBPMAX,NBEMAX, > RTVL,NRTMAX,NBENEW,IERR) IF( IERR.NE.0 )THEN C WRITE(*,*) 'ARETE = ',J GOTO 9999 ENDIF C --- HERITAGE DU MATERIAU ---> DANS R1DIR MAINTENANT C IF( NMT.GT.0 )THEN C JS = J C DO 305 K=1,NBENEW C JS = ITRTRI((JS-1)*NBCMAX+2) C ITBREG(JS) = MATJ C 305 CONTINUE C ENDIF 310 CONTINUE 320 CONTINUE GOTO 9999 C ========================================= C --- 2. RAFFINEMENT ITERATIF --- C ========================================= C 400 CONTINUE NBN1 = NBN DO 420 I=1,NFADEC CALL R1ITER(FADEC, > ITAB((I-1)*NIADEC+1),RTAB((I-1)*IRADEC+1), > MODDEF, > ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,NOEMAX, C > ITBREG,NMT, > ITBREG,NBRMAX,NMT, > COORD,IDIMC,NBN,NBE,NBPMAX,NBEMAX, > ITVL,NITMAX,RTVL,NRTMAX,NBENEW,IERR) IF( IERR.NE.0 )GOTO 9999 420 CONTINUE IF( MODGEN .NE. 3 )GOTO 9999 C ============================ C --- 3. AVEC REGULARISATION --- C ============================ C --- ON PREND LA DERNIERE SUITE --- C RSGMAX = RTAB(NFADEC*IRADEC+1) C DP1MAX = RTAB(NFADEC*IRADEC+2) C ITYPS = ITAB(NFADEC*NIADEC+1) C COMMENT FAIT ON POUR TSN, DEFAUT ET MULTI CONCENTRATION ??? RSGMAX = 1.25 C DP1MAX = 1.E-8 C NE CONVERGE PAS TOUJOURS !! VALEURS ABSOLUES A METTRE EN RELATIF ! DP1MAX = 0.1 ITYPS = 1 DP2MAX = 0.0 DPAMAX = 1.E-6 C --- C'EST LE DEPLACEMENT RELATIF MAXIMUM !!! ----- C IF( DP1MAX.LT. 1.E-8 )DP1MAX = 1.E-8 430 CONTINUE DP3MAX = DP2MAX DP2MAX = 0.0 DO 440 I=NBN1+1,NBN CALL R1LIS(I,ITYPS,RSGMAX,ITRNOE,NBNMAX,ITRTRI,NBCMAX, > NOETRI,COORD,IDIMC,DEPLAC,IERR) DP2MAX = MAX(DEPLAC,DP2MAX) IF( IERR.NE.0 )GOTO 9999 440 CONTINUE C PRINT *,'DEPLACEMENT MAX =',DP2MAX IF( DP2MAX .LT. DPAMAX )GOTO 9999 IF( DP2MAX-DP3MAX / DP2MAX+DP3MAX .GT. DP1MAX )GOTO 430 C 9999 END C C ********************************************************************** C FICHIER : API_RAF1D.F C OBJET : GENERATION ET INSERTION DES POINTS SUR UN MAILLAGE 1D C C FONCT. : C OBJET DS1FCT : RAFFINEMENT D'UN MAILLAGE LINEIQUE (2D,3D) MULTI-REGION C C AUTEUR : O. STAB C DATE : 10.10.98 C TESTS : C MODIFICATIONS : C AUTEUR, DATE, OBJET : O.STAB, 27.07.99, EXTRACTION DE DS1_NOEUD1D.F C O.STAB, 30.07.99, AJOUT DE NBRMAX POUR LE MULTI-REFERENCE DANS : C DS1FCT C C ********************************************************************** C SUBROUTINE DS1FCT(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,NOEMAX, > NBN,NBE,NCC,NBPMAX,NBEMAX, C > ITRIRG,NRGMAX,IMTREF,NMT, > ITRIRG,NBRMAX,NRGMAX,IMTREF,NMT, > COORD,IDIMC, > GRDNOE,NGRDMX, > MODDEF,MODGEN,NBPNEW, > IADEC,NIADEC,RADEC,NRIDEC,NFADEC, > ITVL,NITMAX,RTVL,NRTMAX,ITRACE,IERR) C ********************************************************************** C OBJET DS1FCT : RAFFINEMENT D'UN MAILLAGE LINEIQUE (2D,3D) MULTI-REGION C IDEM DSRAFT ? C EN ENTREE : C ---- DEFINITION DU MAILLAGE -------------- C C ITRIRG : ITRIRG((I-1)*NBRMAX+K) = REFERENCE K DE L'ELEMENT I C NBRMAX : NOMBRE MAXIMUM DE REFERENCE POUR 1 ELEMENT C NRGMAX : TAILLE DE ITRIRG (OU NOMBRE MAXIMUM D'ELEMENT ?) C IMTREF : REFERENCE DES REGIONS C NMT : NOMBRE DE REGIONS ( = TAILLE DE IMTREF) C C GRDNOE : GRDNOE(I) = GRANDEUR ASSOCIEE AU NOEUD I C NBRDMX : TAILLE DE GRDNOE C C ---- DEFINITION DU RAFFINEMENT -------------- C IADEC((I-1)*NIADEC+1) : PARAMETRES ENTIERS DU IEME RAFFINEMENT C NIADEC : NOMBRE MAX. DE PARAMETRES ENTIERS C RADEC((I-1)*NIADEC+1) : PARAMETRES REELS DU IEME RAFFINEMENT C NRIDEC : NOMBRE MAX. DE PARAMETRES REELS C NFADEC : NOMBRE DE RAFFINEMENTS C C NBPNEW : NOMBRE MAXIMUM DE POINTS A GENERER C MODDEF : IL Y A 3 TYPES DE DEFINITIONS C 1 LE MODE DEFAUT SIMPLE C 2 LE MODE CONCENTRATIONS(X,Y) C 3 LE MODE VALEURS NODALES C MODGEN : IL Y A 3 MODES DE GENERATION C 1 LE MODE DIRECT C 2 LE MODE ITERATIF C 3 LE MODE ITERATIF + LISSAGE C C ---- TABLEAUX DE TRAVAIL -------------------- C ITVL : TABLEAU D'ENTIERS POUR LES CALCULS C NITMAX : TAILLE DE ITVL C RTVL : TABLEAU DE REELS POUR LES CALCULS C NRTMAX : TAILLE DE RTVL (12 (NBP+12)) C ITRACE : SI > 0 ALORS ECHO DES ETAPES ET DES RESULTATS C C EN SORTIE : C IERR : CODE D'ERREUR C 0 OK C -1 SI DONNEES INCORRECTES C MODE DE RAFFINEMENT INCONNU C ERREUR FICHIER OUVERTURE/FERMETURE C ERREUR MAILLAGE INCOMPATIBLE AVEC LE TRAITEMENT C ERREUR MAILLAGE INCOHERENT C ERREUR DE TRAITEMENT (REGIONS/RENUMEROTATION/RAFFINEMENT) C -2 SI TABLEAUX INSUFFISANTS C ITVL TROP PETIT C RTVL TROP PETIT) C TROP DE REGIONS (>50) C ERREUR DE TRAITEMENT (REGIONS/RENUMEROTATION/RAFFINEMENT) C ********************************************************************** INTEGER IDE,ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX,NOETRI(*),NOEMAX INTEGER NBN,NBE,NCC,NBPMAX,NBEMAX INTEGER ITRIRG(*),NBRMAX,NRGMAX,IMTREF(*),NMT REAL COORD(*),GRDNOE(*) INTEGER IDIMC,NGRDMX INTEGER ITVL(*) REAL RTVL(*),RADEC(*) INTEGER MODDEF,MODGEN,NBPNEW,IADEC(*),NFADEC,NIADEC,NRIDEC INTEGER NITMAX,NRTMAX,ITRACE,IERR C INTEGER NCCMAX,IERTSA EXTERNAL D1ISUI,DNCHPO C IF( NBPNEW.EQ.0)GOTO 500 GOTO( 100,200,300 ) MODDEF IERR = -1 CALL DSERRE(1,IERR,'DS1FCT','DEFINITION DENSITE INCORRECTE') GOTO 9999 C ======================== C --- RAFFINEMENT PAR DEFAUT --- C ======================== 100 CONTINUE C IF(ITRACE.GT.0) C > CALL ESECHA(1,'-> RAFFINEMENT PAR DEFAUT',' ') NCCMAX = NCC CALL R1RAF(IADEC(1),RADEC(2), > ITRNOE,NBNMAX,ITRTRI,NBCMAX, > NOETRI,NOEMAX, > COORD,IDIMC,NBN,NBE,NBPMAX,NBEMAX,NCC, C modifier r1raf C > ITRIRG,NRGMAX, > ITRIRG,NBRMAX,NRGMAX, > RTVL,NRTMAX, > ITVL,NITMAX,NCCMAX, > IERR) IF(IERR.LT.0)THEN CALL DSERRE(1,IERR,'DS1FCT',' APPEL R1RAF') GOTO 9999 ENDIF GOTO 400 C =========================================== C --- CONCENTRATIONS(X,Y) OU VALEURS NODALES --- C =========================================== 200 CONTINUE C IF(ITRACE.GT.0) C > CALL ESECHA(1,'-> CONCENTRATIONS(X,Y) ',' ') C CALL R1RAFF(MODDEF,MODGEN, > ITRNOE,NBNMAX,ITRTRI,NBCMAX, > NOETRI,NOEMAX, C > ITRIRG,NRGMAX, > ITRIRG,NBRMAX,NRGMAX, > COORD,IDIMC,NBN,NBE,NBPMAX,NBEMAX, > D1ISUI,IADEC,NIADEC,RADEC,NRIDEC,NFADEC, > ITVL,NITMAX,RTVL,NRTMAX, > IERR) IF(IERR.LT.0)THEN CALL DSERRE(1,IERR,'DS1FCT',' APPEL R1RAFF (D1ISUI)') GOTO 9999 ENDIF GOTO 400 C =========================================== C --- VALEURS NODALES --- C =========================================== 300 CONTINUE C IF(ITRACE.GT.0) C > CALL ESECHA(1,'-> VALEURS NODALES ',' ') C CALL R1RAFF(MODDEF,MODGEN, > ITRNOE,NBNMAX,ITRTRI,NBCMAX, > NOETRI,NOEMAX, C > ITRIRG,NRGMAX, > ITRIRG,NBRMAX,NRGMAX, > COORD,IDIMC,NBN,NBE,NBPMAX,NBEMAX, > DNCHPO,IADEC,NIADEC,RADEC,NRIDEC,NFADEC, > ITVL,NITMAX,RTVL,NRTMAX, > IERR) IF(IERR.LT.0)THEN CALL DSERRE(1,IERR,'DS1FCT',' APPEL R1RAFF (DNCHPO)') GOTO 9999 ENDIF GOTO 400 C 400 CONTINUE C TAILLE SOUHAITE ATTEINTE ? (0), NOMBRE MAX ELEMENT (2), NOEUD (1) IERTSA = IERR IERR = 0 C ---- LIMITATION DONNE PAR L'UTILISATEUR --- C IF(ITRACE.NE.0)THEN C IF(IERR.EQ.2) C > CALL ESEINT(1,'NOMBRE MAXIMUM D ELEMENTS ATTEINT: ' C > ,NBEMAX,1) C IF(IERR.EQ.1) C > CALL ESEINT(1,'NOMBRE MAXIMUM DE NOEUDS ATTEINT: ' C > ,NBPNEW,1) C IF(IERR.EQ.0) C > CALL ESEINT(1,'TAILLE SOUHAITEE ATTEINTE: ' C > ,NBN,1) C IERR = 0 C CALL ESEINT(1,'NOMBRE DE NOEUDS : ',NBN,1) C CALL ESEINT(1,'NOMBRE D ELEMENTS : ',NBE,1) C ENDIF C C ================================================ C --- CALCUL DES TAILLES SOUHAITEES AU NOEUDS --- C ================================================ 500 CONTINUE IF( NGRDMX.LE.0 )GOTO 9999 C IF( ITRACE.GT.0 ) C > CALL ESECHA(1,'-> CALCUL DES TAILLES SOUHAITEES',' ') IF( NGRDMX.LT.NBN )THEN IERR = -2 CALL DSERRE(1,IERR,'DS1FCT','PLUS DE PLACE ') GOTO 9999 ENDIF C GOTO( 600,700,800 ) MODDEF C --- RAF PAR DEFAUT 600 CONTINUE CALL DNCCTB(MODDEF,IDE,ITRNOE,NBNMAX,NBE, > ITRTRI,NBCMAX, > 0,IADEC,NIADEC,RADEC,NRIDEC,NFADEC, > COORD,IDIMC,NBN,GRDNOE,IERR) GOTO 1000 C --- CONCENTRATION (X,Y) 700 CONTINUE CALL DNCCTB(MODDEF,IDE,ITRNOE,NBNMAX,NBE, > ITRTRI,NBCMAX, > D1ISUI,IADEC,NIADEC,RADEC,NRIDEC,NFADEC, > COORD,IDIMC,NBN,GRDNOE,IERR) GOTO 1000 C --- VALEURS NODALES 800 CONTINUE CALL DNCCTB(MODDEF,IDE,ITRNOE,NBNMAX,NBE, > ITRTRI,NBCMAX, > DNCHPO,IADEC,NIADEC,RADEC,NRIDEC,NFADEC, > COORD,IDIMC,NBN,GRDNOE,IERR) GOTO 1000 C 1000 CONTINUE IF( IERR.NE.0 )THEN CALL DSERRE(1,IERR,'DS1FCT','APPEL DNCCTB ') GOTO 9999 ENDIF IERR = IERTSA C 9999 END C C ********************************************************************** C MODULE : TRIANGULATION DE DELAUNAY 2D C FICHIER : D2_DELAUNAY.F C OBJET : TRIANGULATION D'UN NUAGE DE POINT C RESPECTANT LE CRITERE DE DELAUNAY C FONCT. : C OBJET TRAJPO : AJOUT D'UN POINT DANS UNE TRIANGULATION DE DELAUNAY 2D C OBJET TRNUPO : TRIANGULATION D'UN NUAGE DE POINTS 2D C C AUTEUR : O. STAB C DATE : C MODIFICATIONS : C AUTEUR, DATE, OBJET : C O.STAB, 07.97, DISTANCE MINI D'UN POINT A LA FRONTIERE DU DOMAINE C O.STAB, 10.97, V.2.0.0 C O.STAB, 11.97, SPCREE REMPLACE PAR SPCERC C o.stab, 01.02, un bug dans TRAJPO !!!! C C C ********************************************************************** C C SUBROUTINE TRAJPO(IPT,ITD,ITRNOE,NBNMAX,ITRTRI,NBCMAX, > NOETRI,NBE,COORD,SPH,NBSMAX, > ITVL,NITMAX,SZERO,DFRMIN,NBTNEW,IERR) C ********************************************************************** C OBJET TRAJPO : AJOUT D'UN POINT DANS UNE TRIANGULATION DE DELAUNAY 2D C C EN ENTREE : C IPT : L'INDICE (DANS COORD) DU POINT A AJOUTER C ITD : L'INDICE (DU TRIANGLE CONTENANT IPT C SI IL N'EST PAS CONNU : 0 C C ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI : LA TRIANGULATION C COORD : COORDONNEES DES NOEUDS DE LA TRIANGULATION C C SPH : TABLEAU DES SPHERES CIRCONSCRITES AUX TRIANGLES C NBSMAX : NOMBRE DE CHAMPS POUR LE CALCUL DES SPHERES (>=2) C C ITVL: TABLEAU DE TRAVAIL. ON Y EMPILE SIMULTANEMENT : C - LES ELEMENTS A DETRUIRE ET LEUR FRONTIERE C - LES ELEMENTS A CONSTRUIRE ET LES SOMMETS PERDUS C NITMAX : TAILLE DU TABLEAU DE TRAVAIL (6*NBADET+10) C C SZERO : SURFACE MINIMUM DES TRIANGLES CREES C SI ELLE EST ATTEINTE LE POINT EST REJETE C DFRMIN : DISTANCE MINI D'UN POINT A LA FRONTIERE DU DOMAINE C SI ELLE EST ATTEINTE LE POINT EST REJETE C C EN SORTIE : LA TRIANGULATION CONTENANT IPT (SI IERR=0) NBE = NBE+2 C NBTNEW : LE NOMBRE D'ELEMENTS CREES C LES ELEMENTS CREES SONT LES TRIANGLES DE NUMERO 1 A NBTNEW C IERR : CODE D'ERREUR 0 SI OK C 1 LE NOEUD N'A PAS PU ETRE AJOUTE (REJET) C LA TRIANGULATION RESTE VALIDE C -1 ERREUR DANS LES DONNEES C LA TRIANGULATION N'EST PAS VALIDE C -2 ITVL TROP PETIT C REMARQUE : C POUR UTILISER TRAJPO ET AJOUTER UN POINT A UNE TRIANGULATION C IL FAUT : C - CREER LA STRUCTURE DU MAILLAGE (CF. SMAOCR) C - INITIALISER SPH EN APPELANT SPHCREE POUR CHAQUE TRIANGLE C - AJOUTER LES COORDONNEES DU POINT A COORD. C ********************************************************************** INTEGER IPT,ITD,NBSMAX,NBTNEW INTEGER ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX INTEGER NOETRI(*),NBE,ITVL(*),NITMAX,IERR REAL SPH(*),COORD(*),SZERO,DFRMIN C --- VARIABLES INTERNES --- INTEGER IDE,NBC,IADETR,NADETR,NBCSTR,IACSTR,NTCMAX INTEGER NBFNOE,ITRACE INTEGER I,J,K, IND, IFR,NIFMAX,NBIFR,ISOMP,NBSOMP INTEGER NBIFR1,IT,ITF,IT1,IFR2,NBCOL,NP, NOEMAX INTEGER ISENS, IDIMC REAL DISPSG EXTERNAL DISPSG INTEGER IP(4) REAL X(2),Y(2),TAILLE INTEGER ITERR, ITAMPO,IPORI,IPEXT INTEGER ITERR2, IAERR, IVOISI REAL ZERO, HAUT C REAL*4 TIMED, TIMEF, TABTIME(2), ETIME C EXTERNAL ETIME C ITRACE = 0 IDIMC = 2 NBTNEW = 0 ZERO = 1.E-30 IDE = IDIMC NBC = IDIMC + 1 NOEMAX = 1 C ==================================== C ---- 1. RECHERCHE DES ELEMENTS A DETRUIRE ------------------- C LES ELEMENTS DONT LE CERCLE CIRCONSCRIT CONTIENNE LE POINT "IPT" C SONT MIS DANS LE TABLEAU ITVL DE "IADETR" JUSQU'A "NADETR" C -------------------------------------------------------------- C TIMED = ETIME(TABTIME) 100 CONTINUE IADETR = 1 IF( ITD.GT.0 )THEN C --- ON CONNAIT 1 TRIANGLE CONTENANT LE POINT : ITD --- ITVL(IADETR) = ITD NADETR = 1 CALL RTCONN(COORD((IPT-1)*IDIMC+1),IDIMC,ITRNOE,NBNMAX, > ITRTRI,NBCMAX,COORD,SPH, > ITVL(IADETR),NADETR,NITMAX,ZERO,IERR) ELSE C --- ON RECHERCHE LES TRIANGLES CONTENANT LE POINT : ITD --- NADETR = 0 CALL RTADET(COORD((IPT-1)*IDIMC+1),IDIMC,ITRNOE,NBNMAX, > ITRTRI,NBCMAX,NBE,COORD,SPH, > ITVL(IADETR),NADETR,NITMAX,ZERO,IERR) ENDIF IF(IERR .NE. 0)THEN IERR = -1 CALL DSERRE(1,IERR,'TRAJPO','APPEL RTADET OU RTCONN') GOTO 9999 ENDIF IF(NADETR.LT.1)THEN C --- MODIF O.STAB 27.08.97 : UN POINT HORS DU DOMAINE EST REJETE ! IERR = 1 CALL DSERRE(1,IERR,'TRAJPO','DANS LA RECHERCHE') GOTO 9999 ENDIF NTCMAX = 2 C C TIMEF = ETIME(TABTIME) C TEMPSCPU(1) = TEMPSCPU(1) + TIMEF - TIMED C C ====================================== C ---- 2. FRONTIERE DES ELEMENTS A DETRUIRE ----------------------------- C ====================================== C TIMED = TIMEF 200 CONTINUE CALL KNUTA(NADETR,ITVL(IADETR)) DO 230 I=1,NTCMAX ITVL(IADETR+NADETR+I-1) = I + NBE DO 210 K=1,NBNMAX ITRNOE(((I+NBE)-1)*NBNMAX + K ) = 0 210 CONTINUE DO 220 K=1,NBCMAX ITRTRI(((I+NBE)-1)*NBCMAX + K ) = 0 220 CONTINUE 230 CONTINUE C ---- LES ELEMENTS SONT MIS EN DEBUT ---- CALL NUCOMP(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI, > NOEMAX,(NBE+NTCMAX),ITVL(IADETR), > (NADETR+NTCMAX),IERR) IF(IERR .NE. 0)THEN CALL DSERRE(1,IERR,'TRAJPO','1 APPEL NUCOMP') GOTO 9999 ENDIF CALL SPCOMP(SPH, NBSMAX, (NBE+NTCMAX),ITVL(IADETR), > (NADETR+NTCMAX),IERR) IF(IERR .NE. 0)THEN CALL DSERRE(1,IERR,'TRAJPO','APPEL SPCOMP') GOTO 9999 ENDIF C ---- CALCUL DE LA FRONTIERE ---- IND = 1 IFR = IADETR + NADETR NBIFR = 0 NIFMAX = NITMAX - NADETR CALL TMAFRT(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,IND,NADETR, > ITVL(IFR),NBIFR,NIFMAX,IERR) IF( IERR .NE. 0 )THEN CALL DSERRE(1,IERR,'TRAJPO','APPEL TMAFRT') GOTO 9999 ENDIF C C TIMEF = ETIME(TABTIME) C TEMPSCPU(2) = TEMPSCPU(2) + TIMEF - TIMED C C ==================== C ---- 3. VERIFICATIONS ---------------------- C ==================== C 300 CONTINUE IACSTR = IFR + ( NBIFR * 2 ) NBCSTR = NBIFR C C ---- 3.1 VERIFICATION DES CARDINAUX ---------------------- C T = 2 * N -A -2 D'OU NBCSTR = (NADETR+2) C IF( NBCSTR .LT. (NADETR+2))THEN IERR = -1 CALL DSERRE(1,IERR,'TRAJPO','UN SOMMET PERDU') GOTO 900 ENDIF IF( NBCSTR .GT. (NADETR+2))THEN IERR = -1 CALL DSERRE(1,IERR,'TRAJPO','PLUSIEURS COMPOSANTES CONNEXES') GOTO 900 ENDIF C C ---- 3.2 VERIFICATION DE LA GEOMETRIE ---------------------- C DO 310 I=1,NBIFR ITVL((I-1)*NBC+IACSTR+2) = IPT CALL TNOFRT(IDE,ITRNOE,NBNMAX,ITVL((I-1)*2+IFR), > ITVL((I-1)*2+IFR+1),ITVL((I-1)*NBC+IACSTR)) C C --- 3.2.1 DISTANCE D'UN POINT A LA FRONTIERE DU DOMAINE > DFRMIN C C IF((DFRMIN.GT.0).AND.(ITVL((I-1)*2+IFR+1).LE.0))THEN C BUG 980904 : IVOISI = ITRTRI( (ITVL((I-1)*2+IFR) -1) * NBCMAX + > ITVL((I-1)*2+IFR+1) ) IF( (DFRMIN.GT.0).AND.(IVOISI.LE.0) )THEN IPORI = ITVL((I-1)*NBC+IACSTR) IPEXT = ITVL((I-1)*NBC+IACSTR+1) HAUT = DISPSG(IDIMC,COORD((IPT-1)*IDIMC+1), > COORD((IPORI-1)*IDIMC+1), > COORD((IPEXT-1)*IDIMC+1)) C --- POINT TROP PROCHE DE LA FRONTIERE --- IF( HAUT .LE. DFRMIN )THEN IERR = -1 GOTO 900 ENDIF ENDIF C C ---- 3.2.2 SURFACE DE L'ELEMENT > SZERO ---- C IP(1) = (I-1)*NBC+IACSTR IP(2) = ITVL(IP(1)) IP(3) = ITVL(IP(1)+1) IP(4) = ITVL(IP(1)+2) X(1) = COORD((IP(3)-1)*IDIMC+1) - COORD((IP(2)-1)*IDIMC+1) Y(1) = COORD((IP(3)-1)*IDIMC+2) - COORD((IP(2)-1)*IDIMC+2) X(2) = COORD((IP(4)-1)*IDIMC+1) - COORD((IP(3)-1)*IDIMC+1) Y(2) = COORD((IP(4)-1)*IDIMC+2) - COORD((IP(3)-1)*IDIMC+2) TAILLE = 0.5 * ( (X(1) * Y(2)) - (Y(1) * X(2)) ) IF( TAILLE.LT.SZERO )THEN C ==================================== C ---- 4.REPRISE SUR ERREUR : RECOMPACTAGE ---- C ==================================== C IERR = -1 C C --- ON PERTURBE LE CALCUL DES SPHERES --- C ITERR = ITVL((I-1)*2+IFR) IAERR = ITVL((I-1)*2+IFR+1) ITERR2 = ITRTRI((ITERR-1)*NBCMAX+IAERR) ITAMPO = ITRNOE(ITERR*NBNMAX) ITRNOE(ITERR*NBNMAX) = ITRNOE(ITERR*NBNMAX-1) ITRNOE(ITERR*NBNMAX-1) = ITRNOE(ITERR*NBNMAX-2) ITRNOE(ITERR*NBNMAX-2) = ITAMPO ITAMPO = ITRTRI(ITERR*NBCMAX) ITRTRI(ITERR*NBCMAX) = ITRTRI(ITERR*NBCMAX-1) ITRTRI(ITERR*NBCMAX-1) = ITRTRI(ITERR*NBCMAX-2) ITRTRI(ITERR*NBCMAX-2) = ITAMPO C CALL SPCERC(IDIMC,ITERR,ITRNOE((ITERR-1)*NBNMAX+1), > COORD,SPH((ITERR-1)*NBSMAX+1),ZERO,IERR) C C --- ON PERTURBE AUSSI LE VOISIN --- C IF( ITERR2.LE.0 )GOTO 900 ITERR = ITERR2 ITAMPO = ITRNOE(ITERR*NBNMAX) ITRNOE(ITERR*NBNMAX) = ITRNOE(ITERR*NBNMAX-1) ITRNOE(ITERR*NBNMAX-1) = ITRNOE(ITERR*NBNMAX-2) ITRNOE(ITERR*NBNMAX-2) = ITAMPO ITAMPO = ITRTRI(ITERR*NBCMAX) ITRTRI(ITERR*NBCMAX) = ITRTRI(ITERR*NBCMAX-1) ITRTRI(ITERR*NBCMAX-1) = ITRTRI(ITERR*NBCMAX-2) ITRTRI(ITERR*NBCMAX-2) = ITAMPO C CALL SPCERC(IDIMC,ITERR,ITRNOE((ITERR-1)*NBNMAX+1), > COORD,SPH((ITERR-1)*NBSMAX+1),ZERO,IERR) GOTO 900 ENDIF 310 CONTINUE C ================================ C ---- 5. FRONTIERE EXTERIEUR DU TROU --------- C ================================ C LES VOISINS SUR LA FRONTIERES DES ELEMENTS A DETRUIRE C 500 CONTINUE NBIFR1 = 0 DO 530 I=1,NBIFR IT = ITVL((I-1)*2+IFR) ITF = ITVL((I-1)*2+IFR+1) C --- FRONTIERE INTERNE --- ISENS = 1 IF( ITF.LT.0 )ISENS = -1 IT1 = ABS(ITRTRI((IT-1)*NBCMAX+(ITF*ISENS))) IF( IT1.NE.0 )THEN DO 510 J=1,NBCMAX IF(ABS(ITRTRI((IT1-1)*NBCMAX+J)).EQ.IT)GO TO 520 510 CONTINUE C --- IT1 VOISIN DE IT, MAIS RECIPROQUE FAUSSE : BUG DANS LA STRUCTURE IERR = -1 CALL DSERRE(1,IERR,'TRAJPO','ERREUR TROU') GO TO 9999 520 NBIFR1 = NBIFR1 + 1 ITVL((NBIFR1-1)*2+IFR) = ABS(IT1) ITVL((NBIFR1-1)*2+IFR+1) = ISENS*J ENDIF 530 CONTINUE C ============================ C ---- 6. DESTRUCTION DES MAILLES ---------------------------- C ============================ C C TIMED = ETIME(TABTIME) 600 CONTINUE NBFNOE = 0 NBSOMP = 0 ISOMP = IACSTR + (NBCSTR * NBC) DO 610 I=1,NADETR CALL SMADET(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NBE,NOETRI, > NBFNOE,I,NBC,ITVL(ISOMP+NBSOMP),NBSOMP,IERR) IF( IERR .NE. 0 )THEN CALL DSERRE(1,IERR,'TRAJPO','ERREUR DESTRUCTION') GOTO 9999 ENDIF 610 CONTINUE NBE = NBE - NADETR IF( NBSOMP.NE.0 )THEN IERR = -1 CALL DSERRE(1,IERR,'TRAJPO','SOMMETS PERDUS') GO TO 9999 ENDIF C C TIMEF = ETIME(TABTIME) C TEMPSCPU(5) = TEMPSCPU(5) + TIMEF - TIMED C ======================================= C ---- 7. CONSTRUCTION DES NOUVEAUX ELEMENTS ----------------- C ======================================= C C TIMED = TIMEF 700 CONTINUE NBFNOE = 0 DO 730 I=1,NBCSTR DO 710 J=1,NBC ITRNOE((I-1)*NBNMAX+J)=ITVL((I-1)*NBC+IACSTR-1+J) ITRTRI((I-1)*NBCMAX+J)=0 710 CONTINUE DO 720 J=1,(I-1) IF( ITRNOE((J-1)*NBNMAX+1).EQ.ITRNOE((I-1)*NBNMAX+2) )THEN ITRTRI((J-1)*NBCMAX+3) = I ITRTRI((I-1)*NBCMAX+2) = J ENDIF IF( ITRNOE((J-1)*NBCMAX+2).EQ.ITRNOE((I-1)*NBCMAX+1) )THEN ITRTRI((J-1)*NBCMAX+2) = I ITRTRI((I-1)*NBCMAX+3) = J ENDIF 720 CONTINUE 730 CONTINUE NOETRI(IPT) = 1 DO 740 I=1,NBCSTR CALL SPCERC(IDIMC,I,ITRNOE((I-1)*NBNMAX+1),COORD, > SPH((I-1)*NBSMAX+1),ZERO,IERR) IF( IERR .NE. 0 )THEN CALL DSERRE(1,IERR,'TRAJPO','APPEL SPCERC') GOTO 9999 ENDIF 740 CONTINUE C C TIMEF = ETIME(TABTIME) C TEMPSCPU(6) = TEMPSCPU(6) + TIMEF - TIMED C =============================== C --- 8. INSERTION DANS LE MAILLAGE --- C =============================== C C TIMED = TIMEF 800 CONTINUE IND = 1 IFR2 = IACSTR NIFMAX = NITMAX - IACSTR CALL TMAFRT(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,IND,NBCSTR, > ITVL(IFR2),NBIFR,NIFMAX,IERR) IF( IERR .NE. 0 )THEN CALL DSERRE(1,IERR,'TRAJPO','FRONTIERE T CREES') GOTO 9999 ENDIF C C --- MISE A JOUR DE ITRTRI ----------------- C CALL S2GLAR(ITVL(IFR),NBIFR1,ITVL(IFR2),NBIFR, > ITRNOE,NBNMAX,ITRTRI,NBCMAX,NBCOL) C C --- MISE A JOUR DE NOETRI ----------------- C DO 820 I=1,NBCSTR DO 810 J=1,NBNMAX NP = ITRNOE((I-1)*NBNMAX+J) IF( NP .NE. 0 )NOETRI(NP)=I 810 CONTINUE 820 CONTINUE NBE = NBE + NBCSTR NBTNEW = NBCSTR C C TIMEF = ETIME(TABTIME) C TEMPSCPU(7) = TEMPSCPU(7) + TIMEF - TIMED GOTO 9999 C C ===================================== C ---- 9.REPRISE SUR ERREUR : RECOMPACTAGE ---- C ===================================== C 900 CONTINUE IERR = 0 C IF( NADETR .EQ. NBE )GO TO 9999 C bug 21.01.2002 OS, remplace par : IF( NADETR .EQ. NBE )GO TO 8888 DO 910 J=1,NADETR ITVL(J) = J 910 CONTINUE DO 920 J=1,NTCMAX ITVL(NADETR+J) = NBE + J 920 CONTINUE CALL NUCOMP(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI, > NOEMAX,(NBE+NTCMAX),ITVL(IADETR), > (NADETR+NTCMAX),IERR) IF(IERR .NE. 0)THEN CALL DSERRE(1,IERR,'TRAJPO','APPEL NUCOMP') GOTO 9999 ENDIF CALL SPCOMP(SPH, NBSMAX, (NBE+NTCMAX),ITVL(IADETR), > (NADETR+NTCMAX),IERR) IF(IERR .NE. 0)THEN CALL DSERRE(1,IERR,'TRAJPO','APPEL SPCOMP') GOTO 9999 ENDIF C ---- LE POINT N'A PAS ETE AJOUTE MAIS LE MAILLAGE RESTE VALIDE 8888 CONTINUE IERR = 1 C 9999 END C C SUBROUTINE TRNUPO(COORD,NBN,ITRNOE,NBNMAX,ITRTRI,NBCMAX, > NOETRI,NBE,ITVL,NITMAX,RTVL,IERR) C ********************************************************************** C OBJET TRNUPO : TRIANGULATION DE DELAUNAY D'UN NUAGE DE POINTS 2D C C EN ENTREE : C COORD : COORDONNEES DES POINTS C NBN : NOMBRE DE POINTS C C ITVL : TABLEAU DE TRAVAIL. ON EMPILE SUCCESSIVEMENT : C LA TRIANGULATION INITIALE QUI NECESSITE : 3 * 50 C PUIS SIMULTANEMENT LE NOMBRE DE NOEUDS REJETES, ET C LE TABLEAU DE TRAVAIL POUR TRAJPO = (6*NBADET +10) C D'OU NITMAX > MAX(150,(6*NBADET+10)+NREJET) C C NITMAX : TAILLE DU TABLEAU DE TRAVAIL C RTVL : TABLEAU DE TRAVAIL DE (8*NBN+244) C C EN SORTIE : LA TRIANGULATION MISE A JOUR C C ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI : LA TRIANGULATION C NBNMAX : =3 A MOINS D'ETRE DONNE (NBNMAX != 0 EN ENTREE) C NBCMAX : =3 A MOINS D'ETRE DONNE (NBCMAX != 0 EN ENTREE) C C IERR : CODE D'ERREUR C -1 TRIANGULATION INCOMPLETE : TOUS LES POINTS N'ONT PAS C PU ETRE AJOUTES C -2 ITVL TROP PETIT C ********************************************************************** REAL COORD(*) INTEGER NBN INTEGER ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX INTEGER NOETRI(*),NBE,ITVL(*),NITMAX,IERR REAL RTVL(*) C --- CONSTANTES --- C PARAMETER ( NBPB = NOMBRE DE POINTS BIDON (50) ) INTEGER NADMAX,NBPB PARAMETER ( NADMAX = 50, NBPB = 50 ) REAL ZEROTR, SZERO C PARAMETER ( ZEROTR = 1.E-30, SZERO = 1.E-8 ) PARAMETER ( ZEROTR = 1.E-30, SZERO = 1.E-16 ) C --- VARIABLES INTERNES --- REAL BOITE(4) INTEGER IDIMC,IDE,NBC,NCOORD, NBFNOE, NOEMAX, ISENS INTEGER ITRAV,NBTRAV,I,J,IPT,ITC,IF2,NP INTEGER ISOMP,NBSOMP,ISPH,NTMEM,NITMX2 INTEGER NCFMAX,NREJET,NBP,ICOORD,NPASSE INTEGER ITD,NBSMAX,NBTNEW INTEGER NOP REAL DFRMIN C ITRAV = 1 NITMX2 = NITMAX IDIMC = 2 NBSMAX = 3 NBE = 0 IERR = 0 IF( NBN .EQ. 0 )GOTO 9999 IF( NBNMAX.EQ.0 )NBNMAX = 3 IF( NBCMAX.EQ.0 )NBCMAX = 3 IF(( NBNMAX.LT.3 ).OR.(NBCMAX.LT.3).OR.(IDIMC.NE.2))THEN IERR = -1 CALL DSERRE(1,IERR,'TRNUPO','EN 2D SEULEMENT') GOTO 9999 ENDIF C NBE = (2*(NBN+4)) + 2 - 4 C NTMEM =(NBE*3)+((NBE+2)*2)+(NBE*3)+((NBN*7)+NBE) C NBE = 2*NBN + 6 C NTMEM = 27 * NBN NTMEM = MAX(150,(6*NADMAX+10)) IF( NTMEM.GT.NITMAX )THEN IERR = -2 CALL DSERRE(1,IERR,'TRNUPO','ITVL TROP PETIT') GO TO 9999 ENDIF C =================== C ---- 1. INITIALISATION ----------------------------------------- C NORMALISATION DES POINTS (PTINIT) C CALCUL DU MAILLAGE INITIAL ENGLOBANT (T2INIT) C CALCUL DES SPHERES CIRCONSCRITES C ---------------------------------------------------------------- NBE = 0 IDE = IDIMC NBC = IDIMC + 1 NCOORD = NBN ISPH = IDIMC * ( NBN + NBPB ) + 1 ICOORD = 1 C ITRI = 1 DO 110 I=1,IDIMC BOITE(I) = -1.0 BOITE(IDIMC+I) = 1.0 110 CONTINUE CALL PTINIT(COORD,IDIMC,NBN,ZEROTR,RTVL(ICOORD),IERR) IF( IERR .NE. 0 )THEN CALL DSERRE(1,IERR,'TRNUPO','APPEL PTINIT') GOTO 9999 ENDIF C C --- TRIANGULATION DE LA "BOITE D'ENCOMBREMENT" -------------------- C ON AJOUTE NBPB POINTS "BIDON" A L'EXTERIEUR DE LA BOITE NCOORD = NCOORD + NBPB NOEMAX = NCOORD C CALL T2ISP(BOITE,(1-NBN),NBPB, > ITRNOE,NBNMAX,ITRTRI,NBCMAX, > NOETRI(NBN+1),NOEMAX,NBE, > RTVL((NBN*IDIMC)+ICOORD),NCOORD,IERR) IF( IERR .NE. 0 )THEN CALL DSERRE(1,IERR,'TRNUPO','APPEL T2ISP') GOTO 9999 ENDIF C ---- TRANSLATION DES NBPT POINT EN FIN ---- DO 120 I=1,(NBE*NBNMAX) ITRNOE(I) = ITRNOE(I) + NBN 120 CONTINUE DO 130 I=1,NBE CALL SPCERC(IDIMC,I,ITRNOE((I-1)*NBNMAX+1),RTVL(ICOORD), > RTVL((I-1)*NBSMAX+ISPH),ZEROTR,IERR) IF( IERR .NE. 0 )THEN CALL DSERRE(1,IERR,'TRNUPO','APPEL SPCERC') GOTO 9999 ENDIF 130 CONTINUE NCFMAX = IDE C ==================== C ---- 2. AJOUT DES NOEUDS ---------------------------------------- C ==================== C IPT = 2 NPASSE = 0 DO 210 I=IPT,NBN ITVL(I)=I 210 CONTINUE C ITD = 0 NBP = NBN NREJET = 0 220 CONTINUE IERR = 0 DFRMIN = 0.0 ITRAV = NBP + 1 NITMX2 = NITMAX - ITRAV + 1 CALL TRAJPO(ITVL(IPT),ITD,ITRNOE,NBNMAX,ITRTRI, > NBCMAX,NOETRI,NBE,RTVL(ICOORD),RTVL(ISPH), > NBSMAX,ITVL(ITRAV),NITMX2,SZERO, > DFRMIN,NBTNEW,IERR) C IF( IERR.NE.0 )THEN C ----- PERMUTATION : EN FIN ------- NREJET = NREJET + 1 ITVL(NREJET) = ITVL(IPT) ENDIF IPT = IPT+1 IF( IPT .LE. NBP )GO TO 220 C -------- ON PASSE AU REJETES --------- C -------- TOUS LES POINTS REJETES ----- IF( NREJET .GE. NBP )THEN IF( NPASSE .LT. 10 )THEN NPASSE = NPASSE + 1 NBP = NREJET IPT = 1 NREJET = 0 IERR = 0 GOTO 220 ELSE IERR = -1 CALL DSERRE(1,IERR,'TRNUPO','BOUCLE REJET') IERR = 0 GO TO 310 ENDIF ENDIF C IF( NREJET .NE. 0 )THEN NPASSE = 0 NBP = NREJET IPT = 1 NREJET = 0 GO TO 220 ENDIF C =================================== C ---- 3. DESTRUCTION DES ELEMENTS BIDON -------------------------- C =================================== C 310 CONTINUE ISENS = 1 NBFNOE = 1 DO 330 I=1,NBPB NP = NBN + I 320 CALL SESFR2(NP,ISENS,IDE,ITRNOE,NBNMAX,ITRTRI, > NBCMAX,NOETRI,ITC,IF2) C --- DE LA PREMIERE ARETE DE FRONTIERE --- IF( ITC.EQ. 0 )GO TO 330 IF( ITRTRI((ITC-1)*NBCMAX+IF2) .NE. 0 )THEN IERR = -1 CALL DSERRE(1,IERR,'TRNUPO','DESTRUCTION FINALE') GO TO 9999 ENDIF C --- L'ELEMENT EST MIS A LA FIN : PERMUTE ITC ET NBE --------- CALL NUPERM(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI, > NBFNOE,NBE,ITC,NBE,IERR) IF( IERR .NE. 0 )THEN CALL DSERRE(1,IERR,'TRNUPO','APPEL NUPERM') GO TO 9999 ENDIF C --- LE DERNIER ELEMENT EST DETRUIT -------------------------- ISOMP = 1 NBSOMP = 0 CALL SMADET(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NBE,NOETRI, > NBFNOE,NBE,NBC,ITVL(ISOMP),NBSOMP,IERR) NBE = NBE-1 IF( IERR .NE. 0 )THEN C IERR = -1 CALL DSERRE(1,IERR,'TRNUPO','APPEL SMADET') GO TO 9999 ENDIF IF( NBSOMP .EQ. 0 )GO TO 320 C --- LE NOEUD (NBN + I) EST DECONNECTE ---------------------- 330 CONTINUE C --- MISE A JOUR DE NOETRI : O(3*NBE) --- DO 350 I=1,NBE DO 340 J=1,3 NOP = ITRNOE((I-1)*NBNMAX+J) IF((NOP.GT.NBN).OR.(NOP.LE.0))THEN IERR = -1 CALL DSERRE(1,IERR,'TRNUPO','STRUCTURE NON CORRECTE') GOTO 9999 ENDIF NOETRI(NOP) = I 340 CONTINUE 350 CONTINUE C C ---- MODIF 04.97 : C IF( NREJET.NE. 0 )IERR = -1 C 9999 END C ******************************************************************* C FICHIER : D2_EVAL.F C OBJET : EVALUATION DES MAILLAGES 2D C C FONCT. : C OBJET STTREV : EVALUE UN MAILLAGE TRIANGULAIRE 2D / 3D C C AUTEUR : O. STAB C DATE : 07.95 C TESTS : 07.95 C MODIFICATIONS : C AUTEUR, DATE, OBJET : O.STAB, 08.97, RESTRUCTURATION C AUTEUR, DATE, OBJET : O.STAB, 10.97, INTEGRATION V.2.0.0 C AUTEUR, DATE, OBJET : O.STAB, 11.97, RESTRUCTURATION C AUTEUR, DATE, OBJET : O.STAB, 02.03, AJOUT SONBAR,SOANGL,SOANAR C C REMARQUE : les fonctions SONBAR,SOANGL,SOANAR ne servent pas qu'a l'evaluation C Attention elles n'existent pas encore en 3D ! C REMARQUE : Il faudra remplacer STTREV par la nouvelle version C VOIR prog/ev_grandeur.f C ******************************************************************* C FUNCTION SONBAR (ISO,COORD,IDIMC,NBN, > ISOMFR,NBTRSO,ITBASO,IERR) C ********************************************************************** C OBJET SONBAR : RENVOI LE NOMBRE D'ARETE AU SOMMET C EN ENTREE : C ISOMFR : 1 si le sommet appartient a la frontiere C 0 sinon C NBTRSO : nombre de triangles incidents a ISOMM C le nombre de sommets = NBTRSO + ISOMFR C ITABSO : Tableau des sommets connectes a ISOMM (dans l'ordre) C si ISOMFR=0 ITABSE(i) est ferme C si ISOMFR=1 ITBASE(i) est ouvert C REMARQUE : VOIR S2SOTR C ********************************************************************** REAL SONBAR INTEGER ISO,IDIMC,NBN REAL COORD(*) INTEGER ISOMFR,NBTRSO,ITBASO(*) INTEGER IERR C SONBAR = 1.0 * (NBTRSO+ISOMFR) 9999 END C FUNCTION SOANGL(ISO,COORD,IDIMC,NBN, > ISOMFR,NBTRSO,ITBASO,IERR) C ********************************************************************** C OBJET SOANGL : RENVOI L'ANGLE (2D) AU SOMMET C EN ENTREE : C ISOMFR : 1 si le sommet appartient a la frontiere C 0 sinon C NBTRSO : nombre de triangles incidents a ISOMM C le nombre de sommets = NBTRSO + ISOMFR C ITABSO : Tableau des sommets connectes a ISOMM (dans l'ordre) C si ISOMFR=0 ITABSE(i) est ferme C si ISOMFR=1 ITBASE(i) est ouvert C REMARQUE : VOIR S2SOTR C ********************************************************************** REAL SOANGL INTEGER ISO,IDIMC,NBN REAL COORD(*) INTEGER ISOMFR,NBTRSO,ITBASO(*) INTEGER IERR C EXTERNAL TRAGSO REAL TRAGSO C --- calcul des angles --- IF( ISOMFR.EQ.0 )THEN SOANGL = 360 ELSE C --- angle entre la premiere et la derniere arete SOANGL = TRAGSO( > COORD((ISO-1)*IDIMC+1), > COORD((ITBASO(1)-1)*IDIMC+1), > COORD((ITBASO(NBTRSO+ISOMFR)-1)*IDIMC+1),IDIMC) ENDIF 9999 END C FUNCTION SOANAR(ISO,COORD,IDIMC,NBN, > ISOMFR,NBTRSO,ITBASO,IERR) C ********************************************************************** C OBJET SOANAR : RENVOI LE RAPPORT ANGLE/NBELEM C EN ENTREE : C ISOMFR : 1 si le sommet appartient a la frontiere C 0 sinon C NBTRSO : nombre de triangles incidents a ISOMM C le nombre de sommets = NBTRSO + ISOMFR C ITABSO : Tableau des sommets connectes a ISOMM (dans l'ordre) C si ISOMFR=0 ITABSE(i) est ferme C si ISOMFR=1 ITBASE(i) est ouvert C REMARQUE : VOIR S2SOTR C ********************************************************************** REAL SOANAR INTEGER ISO,IDIMC,NBN REAL COORD(*) INTEGER ISOMFR,NBTRSO,ITBASO(*) INTEGER IERR C EXTERNAL SOANGL REAL SOANGL C REAL ANGLE, FNBARE C FNBARE = 1.0 * (NBTRSO+ISOMFR) FNBARE = 1.0 * NBTRSO ANGLE = SOANGL(ISO,COORD,IDIMC,NBN,ISOMFR,NBTRSO,ITBASO,IERR) SOANAR = ANGLE / FNBARE C Prendre la valeur absolue de la difference avec 60 degrees !!! 9999 END C C SUBROUTINE STTREV(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,NOEMAX, > COORD,IDIMC,NBN,NBE, > ITVL,IMAX,RTVL,IRMAX,IERR) C ***************************************************************** C OBJET STTREV : EVALUE UN MAILLAGE TRIANGULAIRE 2D / 3D C EN ENTREE C ITVL : TABLEAU DE TRAVAIL (6*NBADET+10) C IMAX : TAILLE DU TABLEAU DE TRAVAIL C RTVL : TABLEAU DE TRAVAIL COORDONNEES + SPHERES C IRMAX : TAILLE DE RTVL >= 3*(3*NBNPTMAX-2*NBN+NBE) C --------- LE MAILLAGE --------------------- C ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,NOEMAX,NBN,NBE : LE MAILLAGE C COORD,IDIMC: LES COORDONNEES DES NOEUDS C C EN SORTIE : UNE EVALUATION C IERR : CODE D'ERREUR C -1 TOUS LES POINTS N'ONT PAS PU ETRE AJOUTES C -2 ITVL OU RTVL TROP PETIT C REMARQUES : C NBPNEW : LE NOMBRE DE NOEUDS GENERES = NBENEW / 2 C ********************************************************************** INTEGER IDE,NBE,ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX INTEGER ITVL(*),IMAX,IDIMC,NOETRI(*),NOEMAX,NBN,IRMAX,IERR REAL COORD(*),RTVL(*) C EXTERNAL TRSURF,TRRIL2,TRLSL2,TRLRC2 REAL TRSURF,TRRIL2,TRLSL2,TRLRC2 REAL RSUFMN,RSUFMX,RSUFTO INTEGER ISUFMN,ISUFMX,NBESUF REAL RRILMN,RRILMX,RRILTO INTEGER IRILMN,IRILMX,NBERIL REAL RLSLMN,RLSLMX,RLSLTO INTEGER ILSLMN,ILSLMX,NBELSL REAL RLRCMN,RLRCMX,RLRCTO INTEGER ILRCMN,ILRCMX,NBELRC REAL SUFMIN,SUFMAX,RILMIN,RILMAX,LSLMIN,LSLMAX,LRCMIN,LRCMAX C EXTERNAL TRLAG2 REAL TRLAG2 INTEGER ILAGMN,ILAGMX,NBELAG REAL LAGMIN,LAGMAX,RLAGMN,RLAGMX,RLAGTO REAL RAD2DG,DG2RAD C SUFMIN = 0.0 SUFMAX = 0.0 RILMIN = 0.0 RILMAX = 0.2 LSLMIN = 0.0 LSLMAX = 0.2 LRCMIN = 0.0 LRCMAX = 0.2 C RAD2DG = 180.0 / 3.14159265 DG2RAD = 3.14159265 / 180.0 LAGMIN = 0.0 LAGMAX = SIN( 20.0 * DG2RAD ) C C ============ C ---- CALCUL SUF ---- C ============ C CALL EVFCTT(ITRNOE,NBNMAX,TRSURF, > COORD,IDIMC,NBN,NBE, > SUFMIN,SUFMAX,NBESUF, > RSUFMN,ISUFMN,RSUFMX,ISUFMX,RSUFTO,IERR) C C ============ C ---- CALCUL RIL ---- C ============ C CALL EVFCTT(ITRNOE,NBNMAX,TRRIL2, > COORD,IDIMC,NBN,NBE, > RILMIN,RILMAX,NBERIL, > RRILMN,IRILMN,RRILMX,IRILMX,RRILTO,IERR) C C ============ C ---- CALCUL LMIN / LMAX ----- C ============ C CALL EVFCTT(ITRNOE,NBNMAX,TRLSL2, > COORD,IDIMC,NBN,NBE, > LSLMIN,LSLMAX,NBELSL, > RLSLMN,ILSLMN,RLSLMX,ILSLMX,RLSLTO,IERR) C C ============ C ---- CALCUL L/RC ----- C ============ C CALL EVFCTT(ITRNOE,NBNMAX,TRLRC2, > COORD,IDIMC,NBN,NBE, > LRCMIN,LRCMAX,NBELRC, > RLRCMN,ILRCMN,RLRCMX,ILRCMX,RLRCTO,IERR) C C =============== C ---- CALCUL ANGLE ----- C =============== C CALL EVFCTT(ITRNOE,NBNMAX,TRLAG2, > COORD,IDIMC,NBN,NBE, > LAGMIN,LAGMAX,NBELAG, > RLAGMN,ILAGMN,RLAGMX,ILAGMX,RLAGTO,IERR) C RLAGMN = ASIN( RLAGMN ) * RAD2DG RLAGMX = ASIN( RLAGMX ) * RAD2DG C PRINT *,' RLAGTO = ', RLAGTO RLAGTO = ASIN( RLAGTO / NBE ) * RAD2DG LAGMAX = ASIN( LAGMAX ) * RAD2DG C C =========== C ----- AFFICHAGE --------- C =========== WRITE(*,*) 'SURFACE TOTALE = ',RSUFTO WRITE(*,*) '------------- MINIMUM ------------------' WRITE(*,*) 'RIL EST MINIMUM SUR ',IRILMN,' = ',RRILMN WRITE(*,*) 'LL EST MINIMUM SUR ',ILSLMN,' = ',RLSLMN WRITE(*,*) 'LRC EST MINIMUM SUR ',ILRCMN,' = ',RLRCMN WRITE(*,*) 'AGM EST MINIMUM SUR ',ILAGMN,' = ',RLAGMN C WRITE(*,*) '------------- MOYENNE ------------------' WRITE(*,*) 'SUF MOYEN ',RSUFTO / NBE WRITE(*,*) 'RIL MOYEN ',RRILTO / NBE WRITE(*,*) 'LL MOYEN ',RLSLTO / NBE WRITE(*,*) 'LRC MOYEN ',RLRCTO / NBE WRITE(*,*) 'AGM MOYEN ',RLAGTO C WRITE(*,*) '------------- MAXIMUM ------------------' WRITE(*,*) 'RIL EST MAXIMUM SUR ',IRILMX,' = ',RRILMX WRITE(*,*) 'LL EST MAXIMUM SUR ',ILSLMX,' = ',RLSLMX WRITE(*,*) 'LRC EST MAXIMUM SUR ',ILRCMX,' = ',RLRCMX WRITE(*,*) 'AGM EST MAXIMUM SUR ',ILAGMX,' = ',RLAGMX C WRITE(*,*) '------------- CARDINAUX ----------------' WRITE(*,*) NBERIL,' ELEMENTS ONT UN RIL < ',RILMAX WRITE(*,*) NBELSL,' ELEMENTS ONT UN LSL < ',LSLMAX WRITE(*,*) NBELRC,' ELEMENTS ONT UN LRC < ',LRCMAX WRITE(*,*) NBELAG,' ELEMENTS ONT UN AGM < ',LAGMAX WRITE(*,*) '----------------------------------------' C 9999 END C C ********************************************************************** C MODULE : M2 (TRIANGULATION DE DELAUNAY 2D) C FICHIER : M2_POINT.F C OBJET : QUELQUES CALCULS ELEMENTAIRES SUR DES NUAGES DE POINTS C C FONCT. : C POBTEN : CALCUL LA BOITE D'ENCOMBREMENT D'UN NUAGE DE POINTS C PTINIT : INITIALISATION D'UN NUAGE DE POINTS (CF PTNORM) C PTNORM : NORMALISATION D'UN NUAGE DE POINTS [-1.00:+1.00] C C AUTEUR : O. STAB C DATE : 03.95 C MODIFICATIONS : C AUTEUR, DATE, OBJET : C C C ********************************************************************** C SUBROUTINE POBTEN(COORD,IDIMC,NBN,BOITE) C ********************************************************************** C OBJET : CALCUL LA BOITE D'ENCOMBREMENT D'UN NUAGE DE POINTS C EN ENTREE : C COORD : TABLEAU DES COORDONNEES DES POINTS C IDIMC : DIMENSION DE L'ESPACE C NBN : NOMBRE DE POINTS C EN SORTIE : C BOITE : LA BOITE D'ENCOMBREMENT (POINT MINI, POINT MAXI ) C ********************************************************************** REAL COORD(*) INTEGER IDIMC, NBN REAL BOITE(2*IDIMC) C INTEGER I,J C DO 10 I=1,IDIMC BOITE(I) = COORD(I) BOITE(IDIMC+I) = COORD(I) 10 CONTINUE C DO 30 I=2,NBN DO 20 J=1,IDIMC BOITE(J) = MIN(BOITE(J) ,COORD((I-1)*IDIMC+J)) BOITE(IDIMC+J) = MAX(BOITE(IDIMC+J),COORD((I-1)*IDIMC+J)) 20 CONTINUE 30 CONTINUE C 999 END C SUBROUTINE PTNORM(COORD,BOITE,IDIMC,NBN,ZERO,COORDN,IERR) C ********************************************************************** C OBJET : NORMALISATION D'UN NUAGE DE POINTS ENTRE [-1.00:+1.00] C EN ENTREE : C COORD : TABLEAU DES COORDONNEES DES POINTS C BOITE : BOITE D'ENCOMBREMENT C IDIMC : DIMENSION DE L'ESPACE C NBN : NOMBRE DE POINTS C ZERO : ZERO C EN SORTIE : C COORDN : COORDONNEES NORMALISEES C ********************************************************************** REAL COORD(*),BOITE(*),ZERO INTEGER IDIMC, NBN REAL COORDN(*) INTEGER IERR C INTEGER I,J REAL XC(3),COEF C COEF = 0.0 DO 40 I=1,IDIMC XC(I) = (BOITE(I) + BOITE(IDIMC+I)) / 2.0 COEF = MAX(COEF,(BOITE(IDIMC+I) - BOITE(I))) 40 CONTINUE C IF( COEF .LE. ZERO )THEN IERR = -1 GOTO 999 ENDIF COEF = 2.0 / COEF C DO 50 I=1,IDIMC IF( COEF*(BOITE(IDIMC+I) - BOITE(I)) .LE. ZERO )THEN IERR = -1 GOTO 999 ENDIF 50 CONTINUE C DO 70 I=1,NBN DO 60 J=1,IDIMC COORDN((I-1)*IDIMC+J) = (COORD((I-1)*IDIMC+J) - XC(J)) * COEF 60 CONTINUE 70 CONTINUE C 999 END C C SUBROUTINE PTINIT(COORD,IDIMC,NBN,ZERO,COORDN,IERR) C ********************************************************************** C OBJET : INITIALISATION D'UN NUAGE DE POINTS C EN ENTREE : C COORD : TABLEAU DES COORDONNEES DES POINTS C IDIMC : DIMENSION DE L'ESPACE C NBN : NOMBRE DE POINTS C ZERO : ZERO C EN SORTIE : C COORDN : COORDONNEES NORMALISEES C ********************************************************************** REAL COORD(*),ZERO INTEGER IDIMC, NBN REAL COORDN(*) INTEGER IERR C REAL BOITE(6) C CALL POBTEN(COORD,IDIMC,NBN,BOITE) CALL PTNORM(COORD,BOITE,IDIMC,NBN,ZERO,COORDN,IERR) 999 END C C ********************************************************************** C MODULE : M2 (TRIANGULATION DE DELAUNAY 2D) C FICHIER : M2_RECHERCHE.F C OBJET : RECHERCHE PAR PARCOURS DANS UNE TRIANGULATION C FONCT. : C RTCONN : RECHERCHE DES TRIANGLES CONNEXES "NON-DELAUNAY" C RTADET : RECHERCHE DES TRIANGLES A DETRUIRE (IE "NON-DELAUNAY") C A L'AJOUT D'UN POINT C C AUTEUR : O. STAB C DATE : 03.95 C MODIFICATIONS : C AUTEUR, DATE, OBJET : C C C ********************************************************************** C SUBROUTINE RTCONN(XYZPT,IDIMC,ITRNOE,NBNMAX,ITRTRI,NBCMAX, > COORD,SPH,IADET,NBADET,NADMAX,ZERO,IERR) C ********************************************************************** C OBJET : RECHERCHE DES TRIANGLES CONNEXES "NON-DELAUNAY" C EN ENTREE : C XYZPT : COORDONNEES DU POINT AJOUTE C IDIMC : DIMENSION DE L'ESPACE C ITRNOE,NBNMAX,ITRTRI,NBCMAX,COORD : LA TRIANGULATION C SPH : LES SPHERES CIRCONSCRITES AUX TRIANGLES C IADET,NBADET : L'ENSEMBLE DES ELEMENTS "NON-DELAUNAY" C (IE A DETRUIRE) ; EN ENTREE IL DOIT CONTENIR 1 ELEMENT. C NBADET: NOMBRE D'ELEMENTS A DETRUIRE C NBADETMNAX : TAILLE DU TABLEAU IADET C EN SORTIE : C IADET : TABLEAU DES TRIANGLES "NON-DELAUNAY" C NBADET : NOMBRE DE TRIANGLES " " " " C ********************************************************************** REAL XYZPT(*) INTEGER IDIMC INTEGER ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX INTEGER IADET(*),NBADET,NADMAX,IERR REAL COORD(*),SPH(*),ZERO C C C --- POUR LE DEBUG --- C C COMMON /DEBUG/ ITRACE, ITEST, IERROR, IMESS C INTEGER ITRACE, ITEST, IERROR C CHARACTER*256 IMESS C --------------------------------------------------------------------- C --- POUR LES STATS --- C COMMON /STATS/ ICARD(100) INTEGER ICARD C --------------------------------------------------------------------- C --- VARIABLES INTERNES --- INTEGER J,K,NT,IPTDS, NBTRA, IVOIS, IT, ITRA, NBC INTEGER SPPOIN EXTERNAL SPPOIN C IERR = 0 NBC = IDIMC+1 IF( NBADET.NE.1 )THEN IERR = -1 GOTO 999 ENDIF C NBTRA = 0 ITRA = 2 C IT = IADET(1) DO 3 J=1,NBC IVOIS = ITRTRI((IT-1)*NBCMAX+J) IF( IVOIS .LE. 0 )GOTO 3 IADET(ITRA + NBTRA) = IVOIS NBTRA = NBTRA + 1 3 CONTINUE C C ON BOUCLE TANTQUE ITRAVAIL N'EST PAS VIDE C ---------------------------------------- 5 IF( NBTRA .EQ. 0 )GOTO 999 IT = IADET(ITRA) NBTRA = NBTRA-1 ITRA = ITRA + 1 NT =ITRNOE((IT-1)*NBNMAX+1+IDIMC) IF( NT.EQ. 0 )GOTO 5 IPTDS = SPPOIN(IDIMC,COORD((NT-1)*IDIMC+1),XYZPT, > SPH((IT-1)*(IDIMC+1)+1),ZERO) IF( IPTDS.EQ.1 )THEN C --------------------------- C LE TRIANGLE EST A DETRUIRE C --------------------------- NBADET = NBADET+1 IF(NBADET.GT.NADMAX)THEN IERR = -2 GO TO 999 ENDIF IADET(NBADET)= IT C ------------------------------------------ C ON MET LES VOISINS A TRAITER DANS ITRAVAIL C ------------------------------------------ DO 20 J=1,NBC IVOIS = ITRTRI((IT-1)*NBCMAX+J) IF( IVOIS .LE. 0 )GOTO 20 DO 10 K=1,NBADET IF( IVOIS.EQ.IADET(K) )GOTO 20 10 CONTINUE C --- LE VOISIN EST DEJA A TRAITER : BUG6 --- C EN 3D POSSIBLE - EN 2D => ON PERD UN SOMMET C ------------------------------------------- DO 15 K=1,NBTRA IF( IVOIS.EQ.IADET(ITRA+K-1) )GOTO 20 15 CONTINUE C IF((NBTRA+ITRA).GT.NADMAX)THEN IERR = -2 GO TO 999 ENDIF IADET(ITRA + NBTRA) = IVOIS NBTRA = NBTRA + 1 20 CONTINUE ENDIF GOTO 5 999 END C SUBROUTINE RTADET(XYZPT,IDIMC,ITRNOE,NBNMAX,ITRTRI,NBCMAX, > NBE,COORD,SPH, > IADET,NBADET,NADMAX,ZERO,IERR) C ********************************************************************** C OBJET : RECHERCHE DES TRIANGLES A DETRUIRE (IE "NON-DELAUNAY") C A L'AJOUT D'UN POINT C EN ENTREE : C XYZPT : COORDONNEES DU POINT AJOUTE C IDIMC : DIMENSION DE L'ESPACE C ITRNOE,NBNMAX,ITRTRI,NBCMAX,NBE,COORD : LA TRIANGULATION C SPH : LES SPHERES CIRCONSCRITES AUX TRIANGLES C NBADETMNAX : TAILLE DU TABLEAU IADET C ZERO : PRECISION DU TEST "POINT DANS SPHERE" C EN SORTIE : C IADET : TABLEAU DES TRIANGLES "NON-DELAUNAY" C NBADET : NOMBRE DE TRIANGLES " " " " C ********************************************************************** REAL XYZPT(*) INTEGER IDIMC INTEGER ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX INTEGER NBE,IADET(*),NBADET,NADMAX,IERR REAL COORD(*),SPH(*),ZERO C C C --- POUR LE DEBUG --- C C COMMON /DEBUG/ ITRACE, ITEST, IERROR, IMESS C INTEGER ITRACE, ITEST, IERROR C CHARACTER*256 IMESS C --------------------------------------------------------------------- C --- POUR LES STATS --- C COMMON /STATS/ ICARD(100) INTEGER ICARD C --------------------------------------------------------------------- C --- VARIABLES INTERNES --- INTEGER I,NT,IPTDS,IPTDSC,IPTDS2,ITRACE REAL SPHC(4) INTEGER SPPOIN, SPPOI2,SPCIRC EXTERNAL SPPOIN, SPPOI2,SPCIRC C ITRACE = 0 IERR = 0 NBADET = 0 DO 30 I=1,NBE C ----- ON PREND LE DERNIER NOEUD --- NT =ITRNOE((I-1)*NBNMAX+1+IDIMC) IF ( NT.EQ. 0 ) GO TO 30 IPTDS = SPPOIN(IDIMC,COORD((NT-1)*IDIMC+1),XYZPT, > SPH((I-1)*(IDIMC+1)+1),ZERO) C C ---- POUR LE DEBUG ---- C IF( ITRACE .GT. 0 )THEN IPTDS2 = SPPOI2(IDIMC,COORD((NT-1)*IDIMC+1),XYZPT, > SPH((I-1)*(IDIMC+1)+1),ZERO) IF( IPTDS2.NE.IPTDS )THEN ICARD(1) = ICARD(1) + 1 C PRINT *,'DIFFERENCE DE CALCUL' C PRINT *,'SPPOI2 = ',IPTDS2,' SPPOIN = ',IPTDS C PRINT *, (SPHC(J),J=1,3) IPTDS = SPPOIN(IDIMC,COORD((NT-1)*IDIMC+1),XYZPT, > SPH((I-1)*(IDIMC+1)+1),ZERO) IPTDS2 = SPPOI2(IDIMC,COORD((NT-1)*IDIMC+1),XYZPT, > SPH((I-1)*(IDIMC+1)+1),ZERO) ENDIF C IPTDSC=SPCIRC(ITRNOE((I-1)*NBNMAX+1),COORD,SPHC,ZERO) IPTDSC=SPPOIN(IDIMC,COORD((NT-1)*IDIMC+1),XYZPT, > SPHC(1),ZERO) IF(( SPHC(1).NE. SPH((I-1)*(IDIMC+1)+1)).OR. > ( SPHC(2).NE. SPH((I-1)*(IDIMC+1)+2)).OR. > ( SPHC(3).NE. SPH((I-1)*(IDIMC+1)+3)))THEN C PRINT *,'ERREUR SUR LA SPHERE' C PRINT *, (SPH((I-1)*(IDIMC+1)+J),J=1,3) C PRINT *, (SPHC(J),J=1,3) ENDIF ENDIF C ------------------------ IF( IPTDS.EQ.1 )THEN IADET(1) = I NBADET = 1 CALL RTCONN(XYZPT,IDIMC,ITRNOE,NBNMAX,ITRTRI,NBCMAX, > COORD,SPH,IADET,NBADET,NADMAX,ZERO,IERR) GOTO 999 ENDIF C 30 CONTINUE 999 END C ********************************************************************** C MODULE : M2 (TRIANGULATION DE DELAUNAY 2D) C FICHIER : M2_SCULPT.F C OBJET : DETERMINE LE PLEIN ET LE VIDE DANS UNE TRIANGULATION C C SCULPT : SCULPT DETERMINE LE PLEIN ET LE VIDE A PARTIR C DE FRONTIERES DONNEES C C FONCT. : C C AUTEUR : O. STAB C DATE : 03.95 C MODIFICATIONS : C AUTEUR, DATE, OBJET : C O.STAB / 20.11.95 / BUG_12 CORRECTION DE SCULPT C O.STAB / 03.11.97 / BUG_41 CORRECTION DE SCMAT C O.STAB / 26.01.99 / GENERALISATION 3D (CHG SFRIDE,SFRICR) C C C ********************************************************************** C SUBROUTINE SCRGCC(IT,IREGIO,IDE,ITRTRI,NBCMAX,NBE, > ITVL,IMAT,NBEMAT,IERR) C ********************************************************************** C OBJET SCRGCC : ASSOCIE UN NUMERO DE REGION AUX ELEMENTS DE LA CC A IT C (COMPOSANTE CONNEXE A IT) C IREGIO : NUMERO DE LA REGION (DOIT ETRE NON-NUL) C ITVL : TABLEAU DE TRAVAIL = NBE + PILE (APPEL TMA1CC) C EN SORTIE : C IMAT : SI I CONNEXE A IT ALORS IMAT(I) = IREGIO C NBEMAT : NOMBRE D'ELEMENTS AFFECTE DU REGION C ********************************************************************** INTEGER IT,IREGIO,IDE,ITRTRI(*),NBCMAX,NBE INTEGER ITVL(*),IMAT(*),NBEMAT,IERR C INTEGER ICON,ITRAV,NBTRAV,IND,I C IERR = 0 NBEMAT = 0 ICON = 1 C --- ON A AU MAXIMUM NBE ELEMENTS CONNEXES AVEC IT --- ITRAV = NBE + ICON NBTRAV = NBE IND = 1 CALL TMA1CC(IDE,ITRTRI,NBCMAX,IND,NBE, > IT,ITVL(ITRAV),IMAT,NBTRAV, > ITVL(ICON),NBEMAT,IERR) IF( IERR.NE. 0 )THEN CALL DSERRE(1,IERR,'SCRGCC',' APPEL TMA1CC ') GOTO 999 ENDIF C PRINT *,NBEMAT,' DE IREGIO = ',IREGIO DO 10 I=1,NBEMAT IMAT(ITVL(I-1+ICON)) = IREGIO C PRINT *,ITVL(I-1+ICON) 10 CONTINUE 999 END C SUBROUTINE SCMAT(IFR,NBNIFR,NBIFR, > IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX, > NOETRI,NBE,ITVL,NITMAX, > IMAT,NPLEIN,NCREUX,IERR) C ********************************************************************** C OBJET SCMAT : DETERMINE LE PLEIN (1) ET LE CREUX (-1) C A PARTIR DE FRONTIERES DONNEES C EN ENTREE : C IFR : LES ELEMENTS DES FRONTIERES C NBIFR : NOMBRE D'ELEMENTS FRONTIERE C C ITVL : TABLEAU DE TRAVAIL = NBE + PILE (APPEL TMA1CC) C NITMAX : TAILLE DU TABLEAU DE TRAVAIL C C EN SORTIE : C IMAT : IMAT(I) = 1 SI L'ELEMENT EST PLEIN C -1 SI " " " " CREUX C NPLEIN : NOMBRE DE COMPOSANTES CONNEXES PLEINES C NCREUX : NOMBRE DE COMPOSANTES CONNEXES CREUSES C IERR : CODE D'ERREUR C -1 UN ELEMENT FRONTIERE DE IFR N'EXISTE PAS C -2 ITVL TROP PETIT C ********************************************************************** INTEGER IFR(*),NBIFR,NBNIFR,IDE INTEGER ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX INTEGER NOETRI(*),NBE,ITVL(*),NITMAX,IMAT(*) INTEGER NPLEIN,NCREUX,IERR C INTEGER NBVUE,IT1,IT2,I1,I2,NBEMAT,IREGIO,I,J INTEGER NBNE,NBCE INTEGER STRNBN,STRNBC EXTERNAL STRNBN,STRNBC C =================== C --- 1. INITIALISATION ---- C =================== NPLEIN = 0 NCREUX = 0 IERR = -1 DO 10 I=1,NBIFR CALL SFRICR(IFR((I-1)*NBNIFR+1),NBNIFR,IDE, > ITRNOE,NBNMAX,ITRTRI,NBCMAX, > NOETRI,NBE,ITVL,NITMAX,IERR) IF( IERR.NE. 0 )THEN CALL DSERRE(1,IERR,'SCMAT',' APPEL SFRICR ') C PRINT *,'L ARETE N EXISTE PAS : ',IFR((I-1)*NBNIFR+1), C > IFR((I-1)*NBNIFR+2) C PRINT *,'NOETRI(O) : ',NOETRI(IFR((I-1)*NBNIFR+1)) C PRINT *,'NOETRI(E) : ',NOETRI(IFR((I-1)*NBNIFR+2)) GOTO 9999 ENDIF 10 CONTINUE DO 20 I=1,NBE IMAT(I) = 0 20 CONTINUE IERR = 0 C ==================================================== C --- 2. RECHERCHE DES FRONTIERES DONNEES NON RECONNUES ---- C SI UNE DES REGIONS EST CONNUE, L'AUTRE L'EST AUSSI C ==================================================== C NBVUE = 0 I = 0 30 I = MOD(I,NBIFR)+1 CALL SFRIDE(IFR((I-1)*NBNIFR+1),NBNIFR,IDE, > ITRNOE,NBNMAX,ITRTRI,NBCMAX, > NOETRI,NBE,ITVL,NITMAX, > IT1,IT2,I1,I2,IERR) IF(IERR.NE.0)THEN CALL DSERRE(1,IERR,'SCMAT','APPEL SFRIDE') GOTO 9999 ENDIF NBEMAT = 0 C ----- FRONTIERE DONNEE EST SUR LA FRONTIERE REELLE --------- IF(IT1.EQ.0)THEN IF(IMAT(IT2).EQ.0)THEN IREGIO = 1 NPLEIN = NPLEIN + 1 CALL SCRGCC(IT2,IREGIO,IDE,ITRTRI,NBCMAX,NBE, > ITVL,IMAT,NBEMAT,IERR) IF(IERR.NE.0)THEN CALL DSERRE(1,IERR,'SCMAT',' 1 APPEL SCRGCC ') GOTO 9999 ENDIF ENDIF GOTO 40 ENDIF IF(IT2.EQ.0)THEN IF(IMAT(IT1).EQ.0)THEN IREGIO = 1 NPLEIN = NPLEIN + 1 CALL SCRGCC(IT1,IREGIO,IDE,ITRTRI,NBCMAX,NBE, > ITVL,IMAT,NBEMAT,IERR) IF(IERR.NE.0)THEN CALL DSERRE(1,IERR,'SCMAT',' 2 APPEL SCRGCC ') GOTO 9999 ENDIF ENDIF GOTO 40 ENDIF C ----- FRONTIERE DONNEE EST A L'INTERIEUR --------- IF((IMAT(IT2).EQ.0).AND. > (IMAT(IT1).EQ.0))GOTO 40 IF((IMAT(IT2).NE.0).AND. > (IMAT(IT1).NE.0))GOTO 40 IF(IMAT(IT1).EQ.0)THEN IREGIO = - IMAT(IT2) IF( IREGIO .EQ. 1 )THEN NPLEIN = NPLEIN + 1 ELSE NCREUX = NCREUX + 1 ENDIF CALL SCRGCC(IT1,IREGIO,IDE,ITRTRI,NBCMAX,NBE, > ITVL,IMAT,NBEMAT,IERR) IF(IERR.NE.0)THEN CALL DSERRE(1,IERR,'SCMAT',' 3 APPEL SCRGCC ') GOTO 9999 ENDIF GOTO 40 ENDIF IF(IMAT(IT2).EQ.0)THEN IREGIO = - IMAT(IT1) IF( IREGIO .EQ. 1 )THEN NPLEIN = NPLEIN + 1 ELSE NCREUX = NCREUX + 1 ENDIF CALL SCRGCC(IT2,IREGIO,IDE,ITRTRI,NBCMAX,NBE, > ITVL,IMAT,NBEMAT,IERR) IF(IERR.NE.0)THEN CALL DSERRE(1,IERR,'SCMAT',' 4 APPEL SCRGCC ') GOTO 9999 ENDIF GOTO 40 ENDIF C C 40 NBVUE = NBEMAT + NBVUE C --- FIN : ON A ATTRIBUE UN MAT. A TOUS LES ELEMENTS ---- IF( NBVUE.EQ.NBE )GOTO 9999 C --- CAS PARTICULIER : ON N'A PAS PU ATTRIBUER UN IREGIO --- IF(( NBVUE.EQ.0 ).AND.(I.EQ.NBIFR))GOTO 50 C --- BOUCLE : ON A PAS VU TOUS LES ELEMENTS --- IF( NBVUE.NE.NBE )GOTO 30 C C ===================================================== C --- 3. CAS PARTICULIER : C LA FRONTIERE DONNEE EST TOTALEMENT A L'INTERIEUR C => RECHERCHE D'UN ELEMENT DE LA FRONTIERE DU CONVEXE C ===================================================== 50 IREGIO = -1 DO 70 I=1,NBE NBNE = STRNBN(I,ITRNOE,NBNMAX) NBCE = STRNBC(NBNE,IDE) DO 60 J=1,NBCE IF( ITRTRI((I-1)*NBCMAX+J).EQ.0 )GOTO 80 60 CONTINUE 70 CONTINUE NCREUX = NCREUX + 1 80 CALL SCRGCC(I,IREGIO,IDE,ITRTRI,NBCMAX,NBE, > ITVL,IMAT,NBEMAT,IERR) IF(IERR.NE.0)THEN CALL DSERRE(1,IERR,'SCMAT',' 5 APPEL SCRGCC ') GOTO 9999 ENDIF C ---- BUG_41 : O.STAB, 03.NOV.97 : ON OUBLIAIT D'INCREMENTER NBVUE ! NBVUE = NBEMAT + NBVUE GOTO 30 C 9999 END C C C C SUBROUTINE SCULPT(IFR,NBNIFR,NBIFR, > IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX, > NOETRI,NBE,ITVL,NITMAX,NCC,IERR) C ********************************************************************** C OBJET SCULPT : DETRUIT LES ELEMENTS EXTERIEURS A UNE FRONTIERE DONNEE C EN ENTREE : C IFR : LES ELEMENTS DES FRONTIERES C NBIFR : NOMBRE D'ELEMENTS FRONTIERE C C ITVL : TABLEAU DE TRAVAIL = 2 * NBE + PILE (APPEL TMA1CC) C NITMAX : TAILLE DU TABLEAU DE TRAVAIL C C EN SORTIE : LA TRIANGULATION MISE A JOUR C ITRNOE,NBNMAX : NOEUDS DES ELEMENTS " " " " C ITRTRI,NBCMAX : ELEMENTS VOISINS C NOETRI : UN DES ELEMENTS INCIDENT A UN POINT C NCC : NOMBRE DE COMPOSANTES CONNEXES C IERR : CODE D'ERREUR C -1 UN ELEMENT FRONTIERE DE IFR N'EXISTE PAS C -2 ITVL OU RTRAVAIL TROP PETIT C ********************************************************************** INTEGER IFR(*),NBIFR,NBNIFR,IDE INTEGER ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX INTEGER NOETRI(*),NBE,ITVL(*),NITMAX,NCC,IERR C INTEGER IMAT,ITRAV,NITMX2 INTEGER ICREUX,NCREUX,NCCREU INTEGER NBSOMP,ISOMP,NBFNOE,I,J,IP,NOEMAX C ======================================= C --- 1. AFFECTATION DES PLEIN ET DES CREUX ---- C ======================================= NCC = 1 IERR = 0 IF( NBIFR.EQ. 0)GOTO 999 IMAT = 1 ITRAV = IMAT + NBE NITMX2 = NITMAX - ITRAV + 1 IF( NITMX2.LT. (2*NBE))THEN IERR = -2 CALL DSERRE(1,IERR,'SCULPT',' TROP D ELEMENTS') GOTO 999 ENDIF C CALL SCMAT(IFR,NBNIFR,NBIFR, > IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX, > NOETRI,NBE,ITVL(ITRAV),NITMX2, > ITVL(IMAT),NCC,NCCREU,IERR) IF( IERR.NE. 0 )THEN CALL DSERRE(1,IERR,'SCULPT',' APPEL SCMAT') GOTO 999 ENDIF NCREUX = 0 ICREUX = IMAT DO 10 I=1,NBE IF( ITVL(I-1+IMAT).EQ.-1 )THEN NCREUX = NCREUX + 1 ITVL(NCREUX-1+ICREUX) = I ENDIF 10 CONTINUE C ================================== C --- 2. DESTRUCTION DES ELEMENTS CREUX ---- C ================================== C C --- 2.1 DECONNECTION DES NOEUDS NOETRI(IP)=0 ---- NOEMAX = 0 C --- BUG_12 CORRIGE LE 20.11.95 O.STAB --------- DO 25 I=1,NCREUX DO 20 J=1,NBNMAX IP = ITRNOE((ITVL(ICREUX-1+I)-1)*NBNMAX+J) IF(IP.NE.0)NOETRI(IP) = 0 20 CONTINUE 25 CONTINUE C --- 2.2 COMPRESSION AU DEBUT --- CALL ENSTRI(ITVL(ICREUX),NCREUX) CALL NUCOMP(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI, > NOEMAX,NBE,ITVL(ICREUX),NCREUX,IERR) IF(IERR .NE. 0)THEN CALL DSERRE(1,IERR,'SCULPT','APPEL NUCOMP') GOTO 999 ENDIF C C --- POUR LE DEBUG --- C CALL DEBSTRF1(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI, C > NBE,NOEMAX,ITRACE,IERR) C IF( IERR .NE. 0 )THEN C CALL DSERRE(1,IERR,'SCULPT',' NUCOMP') C GO TO 999 C ENDIF C --- 2.3 DESTRUCTION --- NBFNOE = 0 NBSOMP = 0 ISOMP = IMAT DO 30 I=1,NCREUX CALL SMADET(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NBE,NOETRI, > NBFNOE,I,NBCMAX,ITVL(ISOMP+NBSOMP),NBSOMP,IERR) IF( IERR .NE. 0 )THEN CALL DSERRE(1,IERR,'SCULPT','APPEL SMADET') GOTO 999 ENDIF 30 CONTINUE C --- BUG_12 CORRIGE LE 20.11.95 O.STAB --------- DO 40 I=1,MIN(NCREUX,NBE-NCREUX) CALL NUPERM(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI, > NOEMAX,NBE,I,(NBE+1-I),IERR) IF( IERR .NE. 0 )THEN CALL DSERRE(1,IERR,'SCULPT','APPEL NUPERM') GOTO 999 ENDIF 40 CONTINUE NBE = NBE - NCREUX C --- POUR LE DEBUG --- C CALL DEBSTRF1(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI, C > NBE-I,NOEMAX,ITRACE,IERR) C IF( IERR .NE. 0 )THEN C CALL DSERRE(1,IERR,'SCULPT',' NUCOMP') C GO TO 999 C ENDIF C IF( NBSOMP.NE.0 )THEN IERR = -1 CALL DSERRE(1,IERR,'SCULPT','SOMMETS PERDUS') C PRINT *, (ITVL(ISOMP),I=1,NBSOMP) GO TO 999 ENDIF C ================================== C --- MISE A JOUR DE NOETRI : O(3*NBE) --- C ================================== DO 70 I=1,NBE DO 60 J=1,NBNMAX IP = ITRNOE((I-1)*NBNMAX+J) IF(IP.NE.0)NOETRI(IP) = I 60 CONTINUE 70 CONTINUE C C 999 END C C ********************************************************************** C MODULE : M2 (TRIANGULATION DE DELAUNAY 2D) C FICHIER : D2_SPH2D.F C OBJET : GESTION DES SPHERES CIRCONSCRITES (CAS 2D) C FONCT. : C OBJET SPCERC : CREER LA SPHERE CIRCONSCRITE AU TRIANGLE C SPPOIN : LE POINT EST-IL DANS LA SPHERE ? C C AUTEUR : O. STAB - S.M. TIJANI C DATE : 03.95 C MODIFICATIONS : C AUTEUR, DATE, OBJET : O.STAB, 13.11.97, RESTRUCTURATION C SPCERC REMPLACE SPCREE, C SPPERM ET SPCOMP VONT DANS ST_SPH.F C C C ********************************************************************** C SUBROUTINE SPCERC(IDIMC,ISPH,ITRI,COORD,SPH,ZERO,IERR) C ********************************************************************** C OBJET SPCERC : CREER LA SPHERE CIRCONSCRITE AU TRIANGLE C EN ENTREE : C IDIMC : DIMENSION DE L'ESPACE C ISPH : NUMERO DU TRIANGLE C ITRI : LES SOMMETS DU TRIANGLE C COORD: TABLEAU DES COORDONNEES DES POINTS C SPH : TABLEAU DES SPHERES C ZERO : C EN SORTIE: C SPH : TABLEAU DES SPHERES AUQUEL A ETE AJOUTE CELLE CREEE C IERR : CODE D'ERREUR -1 SI LE TRIANGLE EST PLAT C C ********************************************************************** INTEGER IDIMC INTEGER ITRI(*),ISPH,IERR REAL COORD(*),SPH(*),ZERO C REAL X1,Y1,X2,Y2,D1,D2,D C REAL S,V C INTEGER I,K C C IF( IDIMC .NE. 2 )THEN C IERR = -1 C GOTO 9999 C ENDIF C SPH(1)=0. SPH(2)=0. C SPH(3)=0. X1=COORD((ITRI(1)-1)*IDIMC+1) - COORD((ITRI(3)-1)*IDIMC+1) Y1=COORD((ITRI(1)-1)*IDIMC+2) - COORD((ITRI(3)-1)*IDIMC+2) X2=COORD((ITRI(2)-1)*IDIMC+1) - COORD((ITRI(3)-1)*IDIMC+1) Y2=COORD((ITRI(2)-1)*IDIMC+2) - COORD((ITRI(3)-1)*IDIMC+2) D1=X1**2+Y1**2 D2=X2**2+Y2**2 D=X2*Y1-X1*Y2 IF(ABS(D).LE.ZERO)THEN IERR = -1 GO TO 9999 ENDIF SPH(1)=(Y1*D2-Y2*D1)/D SPH(2)=(X2*D1-X1*D2)/D IERR = 0 C SPH(3)=SPH(1)**2+SPH(2)**2 C C --- POUR TESTER LE CALCUL : C C DO 20 I=1,3 C S = 0.0 C DO 10 K=1,2 C V = COORD((ITRI(I)-1)*2+K) - COORD((ITRI(3)-1)*2+K) C S = S + V * ( SPH(K) - V ) C 10 CONTINUE C PRINT '(F22.20)',S C 20 CONTINUE C 9999 END C FUNCTION SPCIRC(ITRI,COORD,SPHERE,ZERO) C ********************************************************************** C OBJET SPCIRC : CALCULE LE CERCLE CIRCONSCRIT A UN TRIANGLE C EN ENTREE : C ITRID : NUMERO DES NOEUDS DU TRIANGLE C COORD : COORDONNEES DES NOEUDS C ZERO : PRECISION ( 2* SURFACE MINI. DES TRIANGLES) C EN SORTIE : C SPHERE : VECTEUR DIAMETRE DU CERCLE C LE VECTEUR A POUR ORIGINE LE 3IEME POINT DU TRIANGLE C RENVOI : -1 SI LA SURFACE DU TRIANGLE EST INFERIEUR A "ZERO"/2 C 0 SINON C ---- > OBSOLET REMPLACE PAR SPCERC ! C ********************************************************************** INTEGER SPCIRC INTEGER ITRI(3) REAL COORD(*),SPHERE(3),ZERO C REAL X1,Y1,X2,Y2,D1,D2,D C REAL S,V C INTEGER I,K C SPCIRC = 0 SPHERE(1)=0. SPHERE(2)=0. C SPHERE(3)=0. X1=COORD( ( ITRI(1) - 1 ) *2 +1 ) -COORD( ( ITRI(3) -1 ) * 2+1 ) Y1=COORD( ( ITRI(1) - 1 ) *2 +2 ) -COORD( ( ITRI(3) -1 ) * 2+2 ) X2=COORD( ( ITRI(2) - 1 ) *2 +1 ) -COORD( ( ITRI(3) -1 ) * 2+1 ) Y2=COORD( ( ITRI(2) - 1 ) *2 +2 ) -COORD( ( ITRI(3) -1 ) * 2+2 ) D1=X1**2+Y1**2 D2=X2**2+Y2**2 D=X2*Y1-X1*Y2 IF(ABS(D).LE.ZERO)THEN SPCIRC = -1 GO TO 999 ENDIF SPHERE(1)=(Y1*D2-Y2*D1)/D SPHERE(2)=(X2*D1-X1*D2)/D C SPHERE(3)=SPHERE(1)**2+SPHERE(2)**2 C C --- POUR TESTER LE CALCUL : C C DO 20 I=1,3 C S = 0.0 C DO 10 K=1,2 C V = COORD((ITRI(I)-1)*2+K) - COORD((ITRI(3)-1)*2+K) C S = S + V * ( SPHERE(K) - V ) C 10 CONTINUE C PRINT '(F22.20)',S C 20 CONTINUE 999 END C FUNCTION SPPOI2(IDIMC,U,POINT,BOULE,ZERO) C ********************************************************************** C LE POINT EST-IL A L'EXTERIEUR DU DISQUE OU DE LA BOULE ? C EN ENTREE: C IDIMC : DIMENSION DE L'ESPACE C POINT : COORDONNEES DU POINT A TESTER C BOULE : VECTEUR DIAMETRE DE LA BOULE (CF SPCIRC) C U : LE POINT DE LA BOULE QUI A SERVIT A SON CALCUL(CF SPCIRC) C ZERO : C EN SORTIE : 1 SI "POINT" EST DANS "BOULE", O SINON C ---- > OBSOLET C ********************************************************************** INTEGER SPPOI2 INTEGER IDIMC REAL U(*),POINT(*),BOULE(*),ZERO C REAL V(3),FAC,BV,V2 INTEGER I REAL SPSCVE EXTERNAL SPSCVE C FAC=0.999 SPPOI2=0 C ---- BUG_36 : O.STAB, 17.10.97, BOULE(IDIMC+1) N'EST PAS FORCEMENT C INITIALISE (VOIR SPCIRC) C IF(BOULE(IDIMC+1).LE.ZERO) RETURN DO 10 I=1,IDIMC V(I)= POINT(I)-U(I) 10 CONTINUE BV = FAC*SPSCVE(BOULE,V,IDIMC) V2 = SPSCVE(V,V,IDIMC) IF( BV.LT.V2 )RETURN C --- DANS SPHERE --- SPPOI2=1 END C C FUNCTION SPPOIN(IDIMC,U,POINT,SPHERE,ZERO) C ********************************************************************** C OBJET : LE POINT EST-IL DANS LA SPHERE ? C EN ENTREE: C IDIMC : DIMENSION DE L'ESPACE C POINT : COORDONNEES DU POINT A TESTER C SPHERE : VECTEUR DIAMETRE DE LA SPHERE (CF SPCIRC) C U : LE POINT DE LA SPHERE QUI A SERVIT A SON CALCUL(CF SPCIRC) C EN SORTIE : 1 SI "POINT" EST DANS "SPHERE", O SINON C ********************************************************************** INTEGER SPPOIN INTEGER IDIMC REAL U(*),POINT(*),SPHERE(*),ZERO C REAL V,FAC,S INTEGER I C DATA FAC /.999/ DATA FAC /.999999999/ C S = 0.0 SPPOIN=0 DO 10 I=1,IDIMC V = POINT(I)-U(I) S = S + V * ( (FAC*SPHERE(I)) - V ) 10 CONTINUE IF( S.LT.ZERO )RETURN C --- DANS SPHERE --- SPPOIN=1 END C C FUNCTION SPSCVE(V1,V2,IDIMC) C ********************************************************************** C OBJET : SCALXUTL = V1(L)*V2(1) + V1(2)*V2(2) + ... + V1(N)*V2(N) C ---- > OBSOLET C ********************************************************************** REAL SPSCVE INTEGER IDIMC REAL V1(*),V2(*) C INTEGER I C SPSCVE = 0. IF(IDIMC.LE.0) RETURN DO 10 I=1,IDIMC SPSCVE = SPSCVE + V1(I)*V2(I) 10 CONTINUE END C ********************************************************************** C MODULE : M2 (TRIANGULATION DE DELAUNAY 2D) C FICHIER : M2_TRIANGULATION.F C OBJET : TRIANGULATION INITIALES DE FORMES ELEMENTAIRES C CONTENANT UNE BOITE ET RESPECTANT DELAUNAY C FONCT. : C T2INIT : TRIANGULATION INITIALE AVEC UN POINT INTERIEUR C T2IBT : TRIANGULATION D'UN CARRE CONTENANT LA BOITE C T2ITR : UN TRIANGLE CONTENANT LA BOITE C T2ISP: TRIANGULATION D'UN CERCLE AVEC UN POINT INTERIEUR C C AUTEUR : O. STAB C DATE : 03.95 C MODIFICATIONS : C AUTEUR, DATE, OBJET : C C C ********************************************************************** C SUBROUTINE T2IBT(BOITE,ITRNOE,NBE,COORD,NBN) C ********************************************************************** C OBJET T2IBT : TRIANGULATION D'UN CARRE CONTENANT LA BOITE C EN ENTREE : C BOITE : LA BOITE QUE DOIT CONTENIR LE MAILLAGE C EN SORTIE : C ITRNOE : LA DEFINITION DES TRIANGLES (LEURS POINTS) C NBE : LE NOMBRE D'ELEMENTS C COORD : TABLEAU DES COORDONNEES C NBN : NOMBRE DE POINTS DE LA TRIANGULATION INITIALE C ********************************************************************** REAL BOITE(4),COORD(*) INTEGER NBN,ITRNOE(*),NBE C REAL R, CTR(2), COEF INTEGER I C NBN = -1 NBE = -1 C R = 0.0 DO 10 I=1,2 CTR(I) = (BOITE(2+I) + BOITE(I)) / 2. R = MAX(R,(BOITE(2+I) - BOITE(I))) 10 CONTINUE C COEF = SQRT(2.) * 50. COEF = 2. C COORD(1) = CTR(1) - R * COEF COORD(2) = CTR(2) - R * COEF C COORD(3) = CTR(1) + R * COEF COORD(4) = CTR(2) - R * COEF C COORD(5) = CTR(1) + R * COEF COORD(6) = CTR(2) + R * COEF C COORD(7) = CTR(1) - R * COEF COORD(8) = CTR(2) + R * COEF C ITRNOE(1) = 1 ITRNOE(2) = 2 ITRNOE(3) = 3 ITRNOE(4) = 3 ITRNOE(5) = 4 ITRNOE(6) = 1 C NBN = 4 NBE = 2 C END C C SUBROUTINE T2ITR(BOITE,ITRNOE,NBE,COORD,NBN) C ********************************************************************** C OBJET T2ITR : UN TRIANGLE CONTENANT LA BOITE C EN ENTREE : C BOITE : LA BOITE QUE DOIT CONTENIR LE MAILLAGE C EN SORTIE : C ITRNOE : LA DEFINITION DES TRIANGLES (LEURS POINTS) C NBE : LE NOMBRE D'ELEMENTS C COORD : TABLEAU DES COORDONNEES C NBN : NOMBRE DE POINTS DE LA TRIANGULATION INITIALE C ********************************************************************** REAL BOITE(4),COORD(*) INTEGER NBN,ITRNOE(*),NBE C INTEGER I C COORD(1) = -SQRT(3.)/2. COORD(2) = -0.5 C COORD(3) = SQRT(3.)/2. COORD(4) = -0.5 C COORD(5) = 0. COORD(6) = 1. C DO 10 I=1,6 COORD(I) = 50. * COORD(I) 10 CONTINUE C ITRNOE(1) = 1 ITRNOE(2) = 2 ITRNOE(3) = 3 C NBN = 3 NBE = 1 C END C C SUBROUTINE T2ISP(BOITE,NUM,NBPT, > ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,NOEMAX,NBE, > COORD,NCOORD,IERR) C ********************************************************************** C OBJET T2ISP : TRIANGULATION D'UN CERCLE AVEC UN POINT INTERIEUR C EN ENTREE : C BOITE : LA BOITE QUE DOIT CONTENIR LE MAILLAGE C NUM : NUMERO D'UN POINT A L'INTERIEUR DE LA BOITE C EN SORTIE : C ITRNOE : LA DEFINITION DES TRIANGLES (LEURS POINTS) C NBE : LE NOMBRE D'ELEMENTS C COORD : TABLEAU DES COORDONNEES C NBN : NOMBRE DE POINTS DE LA TRIANGULATION INITIALE C ********************************************************************** REAL BOITE(4) INTEGER NUM,NBPT INTEGER ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX,NOETRI(*),NOEMAX,NBE REAL COORD(*) INTEGER NCOORD,IERR C REAL R, COEF INTEGER I REAL DTETA, TETA, RPI PARAMETER ( RPI = 3.14159265358979323846 ) C C IERR = 0 NBE = 0 COEF = 2. IF( NCOORD.LT.NBPT )THEN IERR = -2 GOTO 9999 ENDIF C C --- GEOMETRIE --- R = 0.0 DO 10 I=1,2 R = MAX(R,(BOITE(2+I) - BOITE(I))) 10 CONTINUE C --- pour l'enseignement : C R = R * 200. IF( NBPT .LT. 3 )THEN IERR = -1 CALL DSERRE(1,IERR,'T2ISP','IL FAUT 3 POINTS') GOTO 9999 ENDIF DTETA = (2 * RPI) / NBPT DO 20 I=1,NBPT TETA = (I-1) * DTETA COORD((I-1)*2+1) = COEF * R * COS(TETA) COORD((I-1)*2+2) = COEF * R * SIN(TETA) 20 CONTINUE IF( NBNMAX.GE. 3 )THEN DO 30 I=1,NBPT ITRNOE((I-1)*NBNMAX+1) = NUM ITRNOE((I-1)*NBNMAX+2) = I ITRNOE((I-1)*NBNMAX+3) = I+1 30 CONTINUE ITRNOE((NBPT-1)*NBNMAX+3) = 1 NBE = NBPT ELSE NBE = 0 ENDIF C --- STRUCTURE DE DONNEES --- IF( NBCMAX.GE.3 )THEN DO 110 I=1,NBPT ITRTRI((I-1)*NBCMAX+1) = I-1 ITRTRI((I-1)*NBCMAX+2) = 0 ITRTRI((I-1)*NBCMAX+3) = I+1 110 CONTINUE ITRTRI(1) = NBE ITRTRI((NBPT-1)*NBCMAX+3) = 1 ENDIF C IF( NOEMAX.GE.NBPT )THEN DO 120 I=1,NBPT NOETRI(I) = I 120 CONTINUE ENDIF C 9999 END C C SUBROUTINE T2INIT(BOITE,NUM,ITRNOE,NBE,COORD,NBN) C ********************************************************************** C OBJET T2INIT : TRIANGULATION INITIALE AVEC UN POINT INTERIEUR C EN ENTREE : C BOITE : LA BOITE QUE DOIT CONTENIR LE MAILLAGE C NUM : NUMERO D'UN POINT A L'INTERIEUR DE LA BOITE C EN SORTIE : C ITRNOE : LA DEFINITION DES TRIANGLES (LEURS POINTS) C NBE : LE NOMBRE D'ELEMENTS C COORD : TABLEAU DES COORDONNEES C NBN : NOMBRE DE POINTS DE LA TRIANGULATION INITIALE C ********************************************************************** REAL BOITE(4),COORD(*) INTEGER NUM, NBN INTEGER ITRNOE(*),NBE C INTEGER IPOLY C IPOLY = 1 GOTO(10,20,30) IPOLY C CALL T2ISP(BOITE,NUM,ITRNOE,NBE,COORD,NBN) 10 GOTO 999 20 CALL T2IBT(BOITE,ITRNOE,NBE,COORD,NBN) GOTO 999 30 CALL T2ITR(BOITE,ITRNOE,NBE,COORD,NBN) 999 END C C ***************************************************************** C MODULE : M3 (RESPECT D'UNE ARETE) C FICHIER : M3_INTER2D.F C OBJET : INTERSECTION D'UN SEGMENT AVEC UN MAILLAGE C TRIANGULAIRE 2D C FONCT. : C TRITSE: CALCULE LES ELEMENTS INTERSECTANT UN SEGMENT C TRDBSE : TRIANGLE AU DEPART D'UN SEGMENT C C AUTEUR : O. STAB C DATE : 03.95 C MODIFICATIONS : C AUTEUR, DATE, OBJET : C O.STAB, 28.03.97, BUG_14 TRITSE DEPASSEMENT DU TABLEAU INTER C C C ***************************************************************** C SUBROUTINE TRITSE(NN,ITRNOE,NBNMAX,ITRTRI,NBCMAX, > NOETRI,NBE,COORD,INTER,NINTER) C ************************************************************* C OBJET TRITSE : DETECTE LES ELEMENTS INTERSECTANT UN SEGMENT C C EN ENTREE: C NN() : LES INDICES DES NOEUDS DU SEGMENT C C ITRTRI,NBNMAX,ITRNOE,NBCMAX,NOETRI,NBE,COORD : LE MAILLAGE C C NINTER : TAILLE DU TABLEAU INTER C C EN SORTIE: C INTER : TABLEAU DES ELEMENTS INTERSECTANT NN C ILS SONT ORDONNEES DE NN(1) VERS NN(2) C NINTER: NOMBRE D'ELEMENTS INTERSECTANT NN C -1 SI LE SEGMENT EST EXTERIEUR OU PASSE PAR UN NOEUD C -2 SI INTER(NINTER) TROP PETIT C NIVEAU : MODULE C ***************************************************************** INTEGER NN(*),ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX INTEGER NOETRI(*),NBE,INTER(*),NINTER REAL COORD(*) C REAL XN(4), DROITE(3), PZERO, X(3),Y(3) INTEGER NLO(3),NBNN,IDE,IDIMC,NBN,I,IT1,IT2,I1,I2,IERR INTEGER ITD,IAD,ITF,IAF,ITS,IARET(3),NBA,ISOM(3),NBS,NS INTEGER NINMAX,ITVL(1),NITMAX C NITMAX = 1 NINMAX = NINTER NINTER = 0 IDE = 2 NBNN = 2 IDIMC = 2 NBN = 3 CALL SFRI2D(NN,NBNN,IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX, > NOETRI,NBE,ITVL,NITMAX,IT1,IT2,I1,I2,IERR) IF(IERR.NE.0)THEN CALL DSERRE(1,IERR,'TRITSE','APPEL SFRI2D') GOTO 9999 ENDIF C IF((IT1.NE.0).OR.(IT2.NE.0))GO TO 9999 C C --- LE SEGMENT N'EST PAS RESPECTE --- C NLO(1) = NN(1) NLO(2) = NN(2) NLO(3) = NN(1) C C --- RECHERCHE DU TRIANGLE DE DEPART --- C CALL TRDBSE(NLO,ITRNOE,NBNMAX,ITRTRI,NBCMAX, > NOETRI,COORD,ITD,IAD) C IF(ITD.EQ.0)THEN C --- on teste si l'un des noeuds n'est pas connecte ! IT1=NOETRI(NN(1)) IT2=NOETRI(NN(2)) IF((IT1.LT.1 ).OR.(IT2.LT.1))THEN CALL DSERRE(1,IERR,'TRITSE','POINT DE FRONTIERE NON CONNECTE') ELSE C l'arete est geometriquement hors du maillage XN(1)=COORD((NN(1)-1)*IDIMC+1) XN(2)=COORD((NN(1)-1)*IDIMC+2) XN(3)=COORD((NN(2)-1)*IDIMC+1) XN(4)=COORD((NN(2)-1)*IDIMC+2) CALL DSERRE(1,IERR,'TRITSE','FRONTIERE HORS DU MAILLAGE') ENDIF IERR=-1 CALL DSERRE(1,IERR,'TRITSE','1 APPEL TRDBSE') GOTO 888 ENDIF C NINTER=NINTER+1 C ----- BUG_14 : 28.03.97 O.STAB --- IF( NINTER.GT. NINMAX )THEN NINTER = -2 CALL DSERRE(1,IERR,'TRITSE','1 TROP D INTERSECTIONS') GOTO 9999 ENDIF INTER(NINTER)= ITD C C --- RECHERCHE DU TRIANGLE D'ARRIVEE --- C CALL TRDBSE(NLO(2),ITRNOE,NBNMAX,ITRTRI,NBCMAX, > NOETRI,COORD,ITF,IAF) IF(ITF.EQ.0)THEN IERR=-1 CALL DSERRE(1,IERR,'TRITSE','2 APPEL TRDBSE') GOTO 888 ENDIF C ----------------------------------------- DO 5 I=1,IDIMC XN(I) = COORD((NN(1)-1)*IDIMC+I) XN(IDIMC+I)= COORD((NN(2)-1)*IDIMC+I) 5 CONTINUE PZERO = 1.E-10 *((XN(3)-XN(1))**2 + (XN(4)-XN(2))**2) C CALL G2DDRO2P( XN, DROITE ) REMPLACE PAR O.STAB CALL DR2PO( COORD((NN(1)-1)*IDIMC+1), > COORD((NN(2)-1)*IDIMC+1),DROITE,IERR) IF(IERR.NE.0)THEN CALL DSERRE(1,IERR,'TRITSE','1 APPEL DR2PO') GOTO 888 ENDIF C ----------------------------------------- ITS = ITRTRI((ITD-1)*NBCMAX+IAD) C -------------------------------------------- 10 IF( ITS .EQ. ITF )GO TO 90 NINTER=NINTER+1 C ----- BUG_14 : 28.03.97 O.STAB --- IF( NINTER.GT. NINMAX )THEN NINTER = -2 GOTO 9999 ENDIF INTER(NINTER)= ITS DO 20 I=1,NBN NS = ITRNOE((ITS-1)*NBNMAX+I) X(I) = COORD((NS-1)*IDIMC+1) Y(I) = COORD((NS-1)*IDIMC+2) 20 CONTINUE CALL INDRPO(X,Y,NBN,DROITE,PZERO,NBA,IARET,NBS,ISOM) IF( NBA .NE.2 )GOTO 888 IF( ITRTRI((ITS-1)*NBCMAX+IARET(1)).EQ.INTER(NINTER-1))THEN ITS = ITRTRI((ITS-1)*NBCMAX+IARET(2)) ELSE ITS = ITRTRI((ITS-1)*NBCMAX+IARET(1)) ENDIF GO TO 10 C --- ON A FINI --- 90 NINTER=NINTER+1 C ----- BUG_14 : 28.03.97 O.STAB --- IF( NINTER.GT. NINMAX )THEN NINTER = -2 CALL DSERRE(1,IERR,'TRITSE','2 TROP D INTERSECTIONS') GOTO 9999 ENDIF INTER(NINTER)= ITF GOTO 9999 888 NINTER= -1 C 9999 END C C SUBROUTINE TRDBSE(NN,ITRNOE,NBNMAX,ITRTRI,NBCMAX, > NOETRI,COORD,ITP,IAR) C ****************************************************** C OBJET : SELECTIONNE LE TRIANGLE INCIDENT A UN NOEUD C ET QUI INTERSECTE UNE DEMI-DROITE PARTANT C DE CE NOEUD C EN ENTREE: C NN() : LES INDICES DES NOEUDS DU SEGMENT C EN SORTIE: C ITP : LE TRIANGLE INTERSECTANT NN C IAR : L'INDICE DE L'ARETE DE ITP INTERSECTEE PAR NN C NIVEAU : FICHIER C ******************************************************** INTEGER NN(*),ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX INTEGER NOETRI(*),ITP,IAR REAL COORD(*) C REAL XN(4), DROITE(3), PZERO, X(2),Y(2),S1,S2 INTEGER IDE,IDIMC,I INTEGER ITPDEB,ISENS,IARDEB,N1,N2,IERR C C --- LE SEGMENT N'EST PAS RESPECTE --- IERR = 0 IDIMC = 2 IDE = 2 DO 10 I=1,IDIMC XN(I) = COORD((NN(1)-1)*IDIMC+I) XN(IDIMC+I)= COORD((NN(2)-1)*IDIMC+I) 10 CONTINUE PZERO = 1.E-10 *((XN(3)-XN(1))**2 + (XN(4)-XN(2))**2) C CALL G2DDRO2P( XN, DROITE ) REMPLACE PAR O.STAB CALL DR2PO( COORD((NN(1)-1)*IDIMC+1), > COORD((NN(2)-1)*IDIMC+1),DROITE,IERR) IF( IERR.NE.0 )THEN CALL DSERRE(1,IERR,'TRDBSE','APPEL DR2PO') GO TO 999 ENDIF C C --- RECHERCHE DE L'ELEMENT DE DEPART --- C -------------------------------------------- ISENS = 1 CALL SESFR2(NN,ISENS,IDE,ITRNOE,NBNMAX,ITRTRI, > NBCMAX,NOETRI,ITP,IAR) C --- LE SOMMET NN(1) EST ISOLE ?! IF((IAR.EQ.-1).OR.(ITP.EQ.0))THEN IERR=-1 CALL DSERRE(1,IERR,'TRDBSE','1 APPEL SESFR2') GO TO 999 ENDIF ITPDEB = ITP IARDEB = IAR C C --- TEST D'INTERSECTION : L'ARETE OPPOSEE --- C 20 I = IAR N2 = ITRNOE((ITP-1)*NBNMAX+I) X(2) = COORD((N2-1)*IDIMC + 1) Y(2) = COORD((N2-1)*IDIMC + 2) I = MOD(I,3)+1 I = MOD(I,3)+1 N1 = ITRNOE((ITP-1)*NBNMAX+I) X(1) = COORD((N1-1)*IDIMC + 1) Y(1) = COORD((N1-1)*IDIMC + 2) C S1 = DROITE(1)*X(1)+DROITE(2)*Y(1)+DROITE(3) S2 = DROITE(1)*X(2)+DROITE(2)*Y(2)+DROITE(3) IF(((S1.GT. PZERO).AND.(S2.LT.-PZERO)).OR. > ((S1.LT.-PZERO).AND.(S2.GT. PZERO)))THEN C --- VERIFICATION DU COTE : PRSCAL > 0--- S1 = ((X(1)-XN(1))*(XN(4)-XN(2))) - > ((Y(1)-XN(2))*(XN(3)-XN(1))) S2 = ((X(1)-XN(1))*(Y(2)-Y(1))) - > ((Y(1)-XN(2))*(X(2)-X(1))) IF( (S1*S2).GT.PZERO )THEN IAR = I GOTO 999 ENDIF ENDIF C --- ON PASSE AU TRIANGLE SUIVANT --- IAR = MOD(IAR,NBCMAX)+1 CALL SESFR1(ITP,IAR,ITRTRI,NBCMAX,ITP,IAR) IF((ITP.NE.ITPDEB ).AND.(ITP.NE.0))GOTO 20 C -- on a pas trouve d'intersection => ERREUR !!! ITP = 0 IAR = 0 IERR=-1 CALL DSERRE(1,IERR,'TRDBSE','1 APPEL SESFR2') 999 END C ***************************************************************** C MODULE : M3 (RESPECT D'UNE ARETE) C FICHIER : M3_RESPECT.F C OBJET : FORCE LE RESPECT DES ARETES FRONTIERE DANS UN MAILLAGE C TRIANGULAIRE 2D C FONCT. : C RF2RAR : IMPOSE LE RESPECTER D'UNE ARETE A UN MAILLAGE C RF2FAR : FORCE LE MAILLAGE A RESPECTER UNE ARETE C C AUTEUR : O. STAB C DATE : 03.95 C TEST : 07.95 C MODIFICATIONS : C AUTEUR, DATE, OBJET : C O.STAB BUG1 DANS RF2FAR C O.STAB, 28.03.97, BUG_14 RF2RAR RETOUR CODE D'ERREUR (TRITSE) C O.STAB, 28.04.97, SUPPRESSION TRPLS2 (DEPLACEE) C AJOUT TRRILF (DEPLACE), AJOUT DE 2 PARAMETRES C D'ENTREE POUR TRPLS2,TRRILF : RDONFR, IDIMC C C ***************************************************************** C FUNCTION TRRILF(P1,P2,P3,IDIMC,RDONFR) C ***************************************************************** C QUALITE DU TRIANGLE : RAYON DU CERCLE INSCRIT SUR ARETE LA PLUS C LONGUE. C RIL = SURFACE / (DEMI PERIMETRE * ARETE LA PLUS LONGUE) C ***************************************************************** INTEGER IDIMC REAL P1(*),P2(*),P3(*),RDONFR(*) C REAL TRRILF REAL XV(3),YV(3),S,D,DMAX INTEGER I C TRRILF = 0.0 XV(1) = P2(1) - P1(1) YV(1) = P2(2) - P1(2) XV(2) = P3(1) - P2(1) YV(2) = P3(2) - P2(2) XV(3) = P1(1) - P3(1) YV(3) = P1(2) - P3(2) S = (XV(1) * YV(2)) - ( XV(2) * YV(1) ) IF( S.LT.0.0 )GOTO 999 DMAX = 0.0 DO 10 I=1,3 D = XV(I)**2 + YV(I)**2 IF( D .GT. DMAX )DMAX = D 10 CONTINUE TRRILF = ( S / DMAX ) 999 END C C SUBROUTINE RF2RAR(NN,ITRNOE,NBNMAX,ITRTRI,NBCMAX, > NOETRI,NBE,COORD, > ITVL,NTIMAX,RTVL,NTRMAX, > NBENEW,IERR) C ***************************************************************** C OBJET : IMPOSE LE RESPECTER D'UNE ARETE A UN MAILLAGE TRIANGULAIRE C C EN ENTREE: C NN() : LES INDICES DES NOEUDS DE L'ARETE C C ITRTRI,NBNMAX,ITRNOE,NBCMAX,NOETRI,NBE,COORD : LE MAILLAGE C C ITVL : TABLEAU DE TRAVAIL (ENTIERS) C NTIMAX : TAILLE DU TABLEAU ITVL C RTVL : TABLEAU DE TRAVAIL (REELS) C C NTRMAX : TAILLE DU TABLEAU RTVL C AU MINIMUM = 9 * NINTER + 10 C AU MAXIMUM = (NBR MAX D'ELEMENTS EN 1 NOEUD + 1) * C NUMERO MAXI DU NOEUD DANS ITRNOE C C EN SORTIE: LE MAILLAGE MODIFIE SI NECESSAIRE. C C NBENEW: LE NOMBRE DE TRIANGLES MODIFIES C ILS ONT LES NUMERO 1 A NBENEW C C IERR : 0 SI OK C -1 SI L'ARETE EST EXTERIEURE OU PASSE PAR UN NOEUD C -2 SI LE NOMBRE DE TRIANGLES INTERSECTES EST TROP GRAND C PEUT ETRE ITVL EST TROP PETIT C ***************************************************************** INTEGER NN(*),ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX INTEGER NOETRI(*),NBE,ITVL(*),NTIMAX,NTRMAX REAL COORD(*), RTVL(*) INTEGER NBENEW,IERR C INTEGER NINTER,ITRAV,INTER,IDIMC C ================================================= C --- 1. CALCUL DES TRIANGLES INTERSECTANT LE SEGMENT --- C ================================================= C ITVL = | INTER | C NINTER C IDIMC = 2 IERR = 0 INTER = 1 NINTER = NTIMAX CALL TRITSE(NN,ITRNOE,NBNMAX,ITRTRI,NBCMAX, > NOETRI,NBE,COORD,ITVL(INTER),NINTER) NBENEW = NINTER IF( NINTER .EQ. 0 ) GO TO 999 C ---- BUG_14 O.STAB 28.03.97 ---- IF( NINTER .LT. 0 )THEN IERR = NINTER CALL DSERRE(1,IERR,'RF2RAR',' APPEL TRITSE') GOTO 999 ENDIF C ==================== C ------- 2.FORCAGE OPTIMUM ---------- C ==================== ITRAV = NINTER + INTER CALL RF2FAR(NN,ITVL(INTER),NINTER, > ITRNOE,NBNMAX,ITRTRI,NBCMAX, > NOETRI,NBE,COORD,ITVL(ITRAV), > (NTIMAX-NINTER),RTVL,NTRMAX,IERR) C IF( IERR .NE. 0 )THEN CALL DSERRE(1,IERR,'RF2RAR',' APPEL RF2FAR') GOTO 999 ENDIF 999 END C C SUBROUTINE RF2FAR(NN,INTER, NINTER, > ITRNOE,NBNMAX,ITRTRI,NBCMAX, > NOETRI,NBE,COORD, > ITVL,NTIMAX,RTVL,NTRMAX,IERR) C ***************************************************************** C OBJET : FORCE LE MAILLAGE A RESPECTER UNE ARETE C C EN ENTREE: C NN() : LES INDICES DES NOEUDS DE L'ARETE C INTER : TABLEAU DES ELEMENTS INTERSECTANTS NN() C NINTER : NBRE D'ELEMENTS DE INTER C AU MINIMUM = 8 * NINTER + 10 C AU MAXIMUM = (NBR MAX D'ELEMENTS EN 1 NOEUD + 1) * C (NUMERO MAXI DES NOEUDS DES ELEMENTS DE INTER) C C ITVL : TABLEAU DE TRAVAIL (ENTIERS) C NTIMAX : TAILLE DU TABLEAU ITVL C RTVL : TABLEAU DE TRAVAIL (REELS) C NTRMAX : TAILLE DU TABLEAU RTVL C C EN SORTIE: LE MAILLAGE MODIFIE SI NECESSAIRE. C IERR : 0 SI OK C -1 SI LES DONNEES SONT ERRONEES C NN(1) OU NN(2) N'APPARTIENNT PAS AUX ELEMENTS DE INTER C -2 SI ITVL EST TROP PETIT C REMARQUE : ATTENTION LES MAILLES DE INTER SONT RENUMEROTEE DE C 1 A CARD(INTER), ITRNOE,ITRTRI...SONT MODIFIES !!! C ***************************************************************** INTEGER NN(*),INTER(*),NINTER,ITRNOE(*),NBNMAX INTEGER ITRTRI(*),NBCMAX,NOETRI(*),NBE INTEGER ITVL(*),NTIMAX,NTRMAX,IERR REAL COORD(*), RTVL(*) C REAL TRRILF EXTERNAL TRRILF C INTEGER IDE,I,NBN,NBC,NBIFR,NBIFR1,IND,IFR INTEGER NIFMAX INTEGER IT,IF,IT1,J, NOEUD, IFR2, NBCOL, NOEMAX INTEGER IPOLY,NBPP,IPOLY1,NBPP1,IPOLY2,NBPP2 INTEGER INOE,ITRI,ITRAV,NBTRAV INTEGER NBFNOE, N, ISOMP, NBSOMP, NCC INTEGER ITRIP1, ITRIP2, ITI, ITR, NTIMX, NTRMX INTEGER NBIFR2 REAL QTMIN1, QTMIN2 REAL RDONFR(1) INTEGER IDIMC C IDIMC = 2 IDE = 2 IERR = 0 IF(NTIMAX.LT.(8*NINTER+10))THEN IERR = -2 GO TO 999 ENDIF C ==================================================== C --- 1. COMPRESSION DU MAILLAGE ET CALCUL DE LA FRONTIERE C ==================================================== C C ITVL = | IFR | C 2*NBIFR C CALL ENSTRI(INTER,NINTER) NOEMAX = 1 CALL NUCOMP(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI, > NOEMAX,NBE,INTER,NINTER,IERR) IF( IERR .NE. 0 )THEN CALL DSERRE(1,IERR,'RF2FAR',' APPEL NUCOMP') GOTO 999 ENDIF C C PRINT *,' ELEMENTS A DETRUIRE ' C PRINT *,' ',((ITRNOE((I-1)*3+J),J=1,3),I=1,NINTER) C IND = 1 IFR = 1 NBIFR = 0 NIFMAX = NTIMAX CALL TMAFRT(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,IND,NINTER, > ITVL(IFR),NBIFR,NIFMAX,IERR) C C PRINT *,' FRONTIERE ' C PRINT *,' ',((ITVL((I-1)*2+IFR-1+J),J=1,2),I=1,NBIFR) IF( IERR .NE. 0 )THEN CALL DSERRE(1,IERR,'RF2FAR',' APPEL TMAFRT') GOTO 999 ENDIF IF( NBIFR .NE. (NINTER+2) )THEN CALL DSERRE(1,IERR,'RF2FAR',' CARDINAL POLYGONE ?') GOTO 999 ENDIF C ========================================= C --- 2. CREATION DES 2 POLYGONES A TRIANGULER. ----- C ========================================= C ITVL = | IFR | INOE | ITRI | IPOLY C 2*NBIFR NBN*NBIFR NBC*NBIFR C NBN = 2 NBC = 2 NBIFR = NINTER + 2 C C --- 2.1 CREATION DU MAILLAGE LINEIQUE --- C ---------------------------------- C LE NOMBRE DE PARAMETRES DE SFRCRE A CHANGE ??? O.STAB 07.95 C > ITRTRI,NBCMAX,NOETRI,NBE,ITVL(ITRAV),NBTRAV, C INOE = ( 2 * NBIFR ) + 1 ITRI = ( NBN * NBIFR ) + INOE ITRAV = ( NBC * NBIFR ) + ITRI C --- ECONOMIE DE FNOETRI -- NBTRAV = (NBC + 1) * NBIFR NBFNOE = 0 NCC = 0 CALL SFRCRE(IDE,ITVL(IFR),NBIFR,ITRNOE,NBNMAX, > ITVL(ITRAV),NBTRAV, > ITVL(INOE),NBN,ITVL(ITRI),NBC,NBIFR, > ITVL(1),NBFNOE,NCC,IERR) C PRINT *,' FRONTIERE ' C PRINT *,' ',((ITVL((I-1)*2+INOE-1+J),J=1,2),I=1,NBIFR) IF( IERR .NE. 0 )THEN CALL DSERRE(1,IERR,'RF2FAR',' APPEL SFRCRE') GOTO 999 ENDIF C PRINT *,' NBIFR, NCC = ',NBIFR,NCC C IF((NBIFR .NE. NBIFR2).OR.(NCC.NE.1))THEN C CALL DSERRE(1,IERR,'RF2FAR',' FRONTIERE NON POLYGONALE') C GOTO 999 C ENDIF C C ---- 2.2 FRONTIERE EXTERIEURE --------- C -------------------------- NBIFR1 = 0 DO 30 I=1,NBIFR IT = ITVL((I-1)*2+IFR) IF = ITVL((I-1)*2+IFR+1) IT1 = ITRTRI((IT-1)*NBCMAX+IF) IF( IT1.NE.0 )THEN DO 10 J=1,NBCMAX IF( ITRTRI((IT1-1)*NBCMAX+J).EQ.IT )GO TO 20 10 CONTINUE IERR = -1 GO TO 999 20 NBIFR1 = NBIFR1 + 1 ITVL((NBIFR1-1)*2+IFR) = IT1 ITVL((NBIFR1-1)*2+IFR+1) = J ENDIF 30 CONTINUE C C ---- DESTRUCTION DES MAILLES SANS MISE A JOUR DE NOETRI ---- C MODIF O.STAB 18.08.95 DEPLACE APRES LE CALCUL C => PERMET UN RETOUR EN ARRIERE EN CAS D'ERREUR C C N = 3 C NBSOMP = 0 C ISOMP = 1 C DO 40 I=1,NINTER C CALL SMADET(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NBE,NOETRI, C > NBFNOE,I,N,ITVL(ISOMP),NBSOMP,IERR) C IF( IERR .NE. 0 )GOTO 999 C 40 CONTINUE C C --- 2.3 CONSTRUCTION DU POLYGONE --- C ----------------------------- C BUG1 : IPOLY = ITRI + ( NBC * NBIFR ) + 1 C REMPLACE PAR : IPOLY = (6* NBIFR) + MAX(1,NBIFR-4) CALL ARTOPL(ITVL(INOE),2,ITVL(ITRI),2, > ITVL(IPOLY),NBPP) C PRINT *,' POLYGONE RESULTANT ' C PRINT *,' ',(ITVL(IPOLY+I),I=0,(NBPP-1)) C PRINT *,' ORIGINE, EXTREMITE = ',NN(1),NN(2) IF( NBPP .LE. 3 )THEN IERR = -1 CALL DSERRE(1,IERR,'RF2FAR', > ' POLYGONE A MOINS DE 4 COTES') GOTO 999 ENDIF C C C --- 2.4 DECOUPAGE DU POLYGONE --- C --------------------------- C ITVL = | IFR | XXXXX | IPOLY1 | IPOLY2 | IPOLY C 2*NBIFR NINTER * 3 NBIFR NBIFR NBIFR C C ON STOQUE D'ABORD LA FRONTIERE PUIS LA TRIANGULATION C PUIS ENFIN LES POLYGONES C IPOLY1 = (2 * NBIFR) + (NINTER * 3 ) + 1 C IPOLY1 CONTIENT AU MAX NBPP COTES (NBPP = NBIFR) C IPOLY2 = IPOLY1 + NBPP - 1 IPOLY2 = IPOLY1 + NBIFR - 1 C DANS LE PIRE CAS C'EST IPOLY2 QUI CONTIENT NBPP COTES CALL SPLIPL(ITVL(IPOLY),NBPP,NN,ITVL(IPOLY1),NBPP1, > ITVL(IPOLY2),NBPP2,IERR) IF(IERR.NE.0)THEN C PRINT *,' POLYGONE RESULTANT ' C PRINT *,' ',(ITVL(IPOLY+I),I=0,(NBPP-1)) C PRINT *,' POLYGONE 1 ' C PRINT *,' ',(ITVL(IPOLY1+I),I=0,(NBPP1-1)) C PRINT *,' POLYGONE 2 ' C PRINT *,' ',(ITVL(IPOLY2+I),I=0,(NBPP2-1)) CALL DSERRE(1,IERR,'RF2FAR',' APPEL SPLIPL') GOTO 999 ENDIF C C =========================== C -------- 3. TRIANGULATION DU TROU ------------------ C =========================== C ITVL = |NBIFR| ITRIP1 | ITRIP2 | IPOLY1 | IPOLY2 | C NINTER * 3 NBIFR NBIFR C ITRIP1 = ( 2 * NBIFR ) + 1 ITRIP2 = ( 3 *(NBPP1-2) ) + ITRIP1 ITR = 1 NTRMX = NTRMAX ITI = IPOLY2 + NBIFR NTIMX = NTIMAX - ITI C CALL TRPLS2(COORD,IDIMC,ITVL(IPOLY1),NBPP1, > ITVL(ITI),NTIMX,RTVL(ITR),NTRMX, > ITVL(ITRIP1),TRRILF,QTMIN1,RDONFR,IERR) IF(IERR.NE.0)THEN CALL DSERRE(1,IERR,'RF2FAR',' PREMIER APPEL TRPLS2') GOTO 999 ENDIF C CALL TRPLS2(COORD,IDIMC,ITVL(IPOLY2),NBPP2, > ITVL(ITI),NTIMX,RTVL(ITR),NTRMX, > ITVL(ITRIP2),TRRILF,QTMIN2,RDONFR,IERR) IF(IERR.NE.0)THEN CALL DSERRE(1,IERR,'RF2FAR',' DEUXIEME APPEL TRPLS2') GOTO 999 ENDIF C PRINT *,'QUALITE T1 QUALITE T2 ' C PRINT '(F7.6,F7.6)',QTMIN1,QTMIN2 C C ======================================================= C ---- 4. DESTRUCTION DES MAILLES SANS MISE A JOUR DE NOETRI ---- C ======================================================= N = 3 NBSOMP = 0 ISOMP = 1 DO 50 I=1,NINTER CALL SMADET(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NBE,NOETRI, > NBFNOE,I,N,ITVL(ISOMP),NBSOMP,IERR) IF( IERR .NE. 0 )THEN CALL DSERRE(1,IERR,'RF2FAR',' APPEL SMADET') GOTO 999 ENDIF 50 CONTINUE C ================================= C --- 5. CREATION DU NOUVEAU MAILLAGE --- C ================================= NBFNOE = 0 C --- ON LIBERE LES IPOLYS --- ITRAV = IPOLY1 NBTRAV = NTIMAX - ITRAV + 1 CALL SMACRE(IDE,ITVL(ITRIP1),NINTER,0, > ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,NBFNOE, > ITVL(ITRAV),NBTRAV,IERR) IF( IERR .NE. 0 )THEN CALL DSERRE(1,IERR,'RF2FAR',' APPEL SMACRE') GOTO 999 ENDIF C --- POUR LE DEBUG ------- C PRINT *,'TABLEAU DES NOEUDS ' C PRINT *,((ITRNOE((I-1)*NBNMAX+J),J=1,NBNMAX),I=1,NINTER) C PRINT *,'TABLEAU DES VOISINS ' C PRINT *,((ITRTRI((I-1)*NBCMAX+J),J=1,NBCMAX),I=1,NINTER) C C --- COLLAGE DES FRONTIERES --- C IND = 1 C --- ON LIBERE LA TRIANGULATION --- IFR2 = ITRIP1 NIFMAX = NTIMAX - ITRIP1 CALL TMAFRT(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,IND,NINTER, > ITVL(IFR2),NBIFR,NIFMAX,IERR) IF( IERR .NE. 0 )THEN CALL DSERRE(1,IERR,'RF2FAR',' APPEL TMAFRT') GOTO 999 ENDIF C C --- MISE A JOUR DE ITRTRI ----------------- C CALL S2GLAR(ITVL(IFR),NBIFR1,ITVL(IFR2),NBIFR, > ITRNOE,NBNMAX,ITRTRI,NBCMAX,NBCOL) C C --- MISE A JOUR DE NOETRI ----------------- C DO 90 I=1,NINTER DO 80 J=1,NBNMAX NOEUD = ITRNOE((I-1)*NBNMAX+J) IF( NOEUD .NE. 0 )NOETRI(NOEUD)=I 80 CONTINUE 90 CONTINUE 999 END C C ***************************************************************** C MODULE : M3 (RESPECT D'UNE ARETE) C FICHIER : M3_TRIPO.F C OBJET : CALCUL DE LA MEILLEURE TRIANGULATION D'UN POLYGONE C SIMPLE C FONCT. : C TRPLS2 : ALLOCATION ET APPEL A TRPLSI C TRPLSI : CALCULE LA TRIANGULATION D'UN POLYGONE SIMPLE C QUI MAXIMISE LA VALEUR MINIMUM D'UN CRITERE DONNE C C AUTEUR : O. STAB C DATE : 03.95 C MODIFICATIONS : C AUTEUR, DATE, OBJET : STAB, 25.04.97, BUG_21 DANS TRPLSI C AUTEUR, DATE, OBJET : STAB, 28.04.97, AJOUT TRPLS2 (DEPLACEE) C SUPPRESSION TRRILF (DEPLACE), AJOUT D'UN PARAMETRE C D'ENTREE POUR TRPLS2 ET TRPLSI :RDONFR C C ***************************************************************** C SUBROUTINE TRPLS2(X,IDIMC,IPOLYG,NCP, > ITVL,NTIMAX,RTVL,NTRMAX, > ITRPOL,FCRMIN,QTMIN,RDONFR,IERR) C ***************************************************************** C OBJET TRPLS2 : ALLOCATION ET APPEL A TRPLSI C C EN ENTREE : C X : COORDONNEES DES POINTS DU POLYGONE C IDIMC : DIMENSION DE L'ESPACE DES COORDONNEES C IPOLYG : NUMERO DES NOEUDS DU POLYGONE C NCP : NOMBRE DE POINT DU POLYGONE C FCRMIN: FONCTION RENVOYANT LA VALEUR DU CRITERE C FUNCTION REAL FCRMIN(P1,P2,P3,IDIMC,RDONFR) C INTEGER IDIMC : DIMENSION DES COORDONNEES DU POLY C REAL P1(*),P2(*),P3(*),RDONFR(*) C OU P1,P2,P3 SONT LES COORDONNEES DES POINTS C DU TRIANGLE, RDONFR(*) D'AUTRES DONNEES C QTMIN : VALEUR MINIMUM DU CRITERE C RDONFR: DONNEES REELLES POUR LA FONCTION "FCRMIN" C C ITVL : TABLEAU DE TRAVAIL DE TAILLE NTIMAX C RTVL : TABLEAU DE TRAVAIL DE TAILLE NTRMAX C C EN SORTIE : C ITRPOL: TRIANGULATION RESULANTE C ITRPOL((I-1)*3+1) PREMIER NOEUD DU TRIANGLE I C ITRPOL((I-1)*3+2) DEUXIEME NOEUD DU TRIANGLE I C ITRPOL((I-1)*3+3) TROISIEME NOEUD DU TRIANGLE I C QTMIN : VALEUR MINIMUM DE FCRMIN SUR ITRPOL C IERR : 0 SI TOUT EST OK C -1 SI QTMIN N'A PAS PU ETRE ATTEINT C -2 SI UN PROBLEME DE TAILLE MEMOIRE C ***************************************************************** REAL X(*),QTMIN INTEGER IDIMC,IPOLYG(*),NCP,ITVL(*),NTIMAX,NTRMAX REAL RTVL(*),RDONFR(*) INTEGER ITRPOL(*),IERR C C NPMAX : LE NOMBRE MAXIMUM DE POLYGONES EMPILES C NCMAX : LE NOMBRE MAXIMUM DE COTE DU POLYGONE C PARAMETER (NPMAX = 1000,NCMAX = 20, IDIMC = 2) C REAL FCRMIN EXTERNAL FCRMIN INTEGER IND,ICARD,JT,IFD,IFG,IT,ITM,IPERE INTEGER ITPOLY,ITRIA,ITRMIN,IQTRIA,IQMIN INTEGER NPMAX,NCMAX C NCMAX = NCP NPMAX = (NTIMAX - 3*(NCMAX-2)) / (2*(2*NCMAX+1)) C WRITE (*,*) '---- LE RESPECT D ARETE ----' C WRITE (*,*) 'COTES DU POLYGONE NCP =',NCP C WRITE (*,*) 'PLACE DISPONIBLE NTIMAX =',NTIMAX C WRITE (*,*) 'TAILLE DE LA PILE NPMAX =',NPMAX C NPMAX = MIN( (NTRMAX / 2),NPMAX ) C WRITE (*,*) 'TAILLE DE LA PILE POUR LE RESPECT D ARETE =',NPMAX IF((NPMAX.LE.0).OR.(NTRMAX.LT.(2*NCMAX)))THEN IERR = -2 GOTO 999 ENDIF C --- ALLOCATION DE TOUS LES TABLEAUX --- IND = 1 ICARD = NPMAX + IND JT = NPMAX + ICARD IFD = NPMAX + JT IFG = NPMAX + IFD IT = NPMAX + IFG ITM = NPMAX + IT IPERE = NPMAX + ITM ITPOLY= NPMAX + IPERE ITRIA = (NPMAX*NCMAX) + ITPOLY ITRMIN= ((NCMAX-2)*3) + ITRIA C ITRMIN((NCMAX-2)*3*NPMAX) C IQTRIA= 1 IQMIN = NPMAX + IQTRIA C IQMIN(NPMAX) C CALL TRPLSI(X,IDIMC,IPOLYG,NCP, > ITVL(IND),ITVL(ICARD),ITVL(JT),ITVL(IFD), > ITVL(IFG),ITVL(IT),ITVL(ITM),ITVL(IPERE), > ITVL(ITPOLY),ITVL(ITRIA), > ITVL(ITRMIN), > RTVL(IQTRIA),RTVL(IQMIN),NPMAX,NCMAX, > ITRPOL,FCRMIN,QTMIN,RDONFR,IERR) C 999 END C C SUBROUTINE TRPLSI(X,IDIMC,IPOLYG,NCP, > IND,ICARD,JT,IFD, > IFG,IT,ITM,IPERE, > ITPOLY,ITRIA, > ITRMIN, > QTRIA,QMIN,NPMAX,NCMAX, > ITRPOL,FCRMIN,QTMIN,RDONFR,IERR) C ***************************************************************** C OBJET TRPLSI: TRIANGULATION MAXIMISANT UN CRITERE DONNE C C EN ENTREE : C ---------- C X : COORDONNEES DES POINTS DU POLYGONE C IDIMC : DIMENSION DE L'ESPACE DES COORDONNEES C IPOLYG: NUMERO DES NOEUDS DU POLYGONE SIMPLE (DEF. SHAMOS) C NCP : NOMBRE DE POINT DU POLYGONE C FCRMIN: FONCTION RENVOYANT LA VALEUR DU CRITERE C FUNCTION REAL FCRMIN(P1,P2,P3,IDIMC,RDONFR) C INTEGER IDIMC : DIMENSION DES COORDONNEES DU POLY C REAL P1(*),P2(*),P3(*),RDONFR(*) C OU P1,P2,P3 SONT LES COORDONNEES DES POINTS C DU TRIANGLE, RDONFR(*) D'AUTRES DONNEES C QTMIN : VALEUR MINIMUM DU CRITERE C RDONFR: DONNEES REELLES POUR LA FONCTION "FCRMIN" C C LES TABLEAUX DE TRAVAIL POUR LES POLYGONES C ------------------------------------------ C IND,ICARD,JT,IFG,IFD,IT,ITM : TABLEAUX DE NPMAX D'ENTIERS, NPMAX C EST LE NOMBRE MAXIMUM DE POLYGONE EMPILES (VOIR REMARQUE). C C QTRIA,QMIN : TABLEAUX DE NPMAX REELS, NPMAX EST LE NOMBRE C MAXIMUM DE POLYGONE EMPILES. C C ITPOLY : TABLEAU DE NPMAX*M ENTIERS, NPMAX EST LE NOMBRE MAXIMUM C DE POLYGONE EMPILES. M LE NOMBRE MOYEN C DE NOEUDS PAR POLYGONE (M 5 TRIANGULATIONS POSSIBLES C NCMAX = 10 => 1430 TRIANGULATIONS POSSIBLES C NCMAX = 14 => 208012 TRIANGULATIONS POSSIBLES C NCMAX = 20 => 477638700 TRIANGULATIONS POSSIBLES C C DANS LE PIRE CAS (QUI DEPEND DE LA FONCTION D'EVALUATION), C LA COMPLEXITE EN PLACE ET TEMPS EST EXPONENTIELLE ! C PAR CONTRE, DANS LE CAS GENERAL LE RESULTAT EST ACCEPTABLE : C POUR UN POLYGONE 14 COTES : 1939 POLYGONES TESTES, C 54 POLYGONES EMPILES C 208012 TRIANGULATIONS POSSIBLES. C C PRINCIPE : VOIR DOC DE CONCEPTION DE DELOS C ---------- C C ALGORITHME : RECURSIF C ------------ C POUR UN POLYGONE, ON CHOISI UN TRIANGLE (1,2,J) LE DECOUPANT EN 2. C ON DESCENT SUR LE FILS DROIT...QUAND LE FILS DROIT = 0 ON C RETOURNE SUR LE FILS GAUCHE PUIS SUR LE PERE. ON OBTIENT C AINSI LA MEILLEUR TRIANGULATION DU POLYGONE CONTENANT LE C TRIANGLE. ON PASSE A UN AUTRE TRIANGLE. C C STRUCTURE DES DONNEES : C ----------------------- C ARBRE DE RECCURSION : C --------------------- C IPI : NUMERO DU POLYGONE COURANT (DANS LA PILE) C IPERE(IPI): NUMERO DU POLYGONE PERE C IFG(IPI) : NUMERO DU POLYGONE FILS GAUCHE C IFD(IPI) : NUMERO DU POLYGONE FILS DROIT C LE PARCOURS FAIT QUE IFG(IPI) = IPI+1, C IFD(IPI) =IPI+2 SI ILS EXISTENT. C C LES POLYGONES C -------------- C ITPOLY : TABLEAU OU SONT DECRITS LES POLYGONES C (LA LISTE DES INDICES DES NOEUDS) C ATTENTION TOUS LES FILS GAUCHES PARATGENT LEURS DONNEES C DANS ITPOLY (NE PAS DESALLOUER : BUG_21) C IND(IPI) : ADRESSE DU DEBUT DU POLYGONE "IPI" DANS "ITPOLY" C ICARD(IPI): NOMBRE DE COTES DU POLYGONE "IPI" C C JT(IPI) : INDICE J DES TRIANGLES (1,2,J) DEJA TESTES C (POUR LA DECOMPOSITION) C ITRIA(IPI): NOEUDS DU TRIANGLE DE DECOMPOSITION C QTRIA(IPI): QUALITE DU TRIANGLE DE DECOMPOSITION C C LES TRIANGULATIONS C ------------------- C ITRMIN : TABLEAU OU SONT DECRITES LES TRIANGULATIONS C QMIN(IPI) : QUALITE MINI DEJA ATTEINTE POUR UNE TRIANGULATION DE IPI C IT(IPI) : ADRESSE DE LA TRIANGULATION COURANTE DE IPI C LE NB DE TRIANGLES = ICARD(IPI) - 2 C ITM(IPI) : ADRESSE DE LA TRIANGULATION MINI DE IPI C C GESTION MEMOIRE : C ----------------- C LIBTL : PREMIERE PLACE LIBRE DANS ITPOLY C LIBTR : " " " " " ITRMIN C LIBPL : " " " " " LES TABLEAUX DES POLY (IND...) C C ***************************************************************** REAL X(*),QTMIN INTEGER IDIMC,IPOLYG(*),NCP,ITRPOL(*),IERR REAL FCRMIN,RDONFR(*) EXTERNAL FCRMIN INTEGER NPMAX,NCMAX C C ---- LES TABLEAUX DE TRAVAIL ---- C INTEGER IND(*),ICARD(*),JT(*),IFD(*) INTEGER IFG(*),IT(*),ITM(*),IPERE(*) INTEGER ITPOLY(*),ITRIA(*) INTEGER ITRMIN(*) REAL QTRIA(*),QMIN(*) C C ---- VARIABLES LOCALES ---- C C INTEGER IDIMC C PARAMETER (IDIMC = 2) INTEGER NBP,II,I,J,K,N,ITP,IPI,LIBTL,LIBTR,LIBPL INTEGER LPLMAX,NPTEST C IF( NCP .GT. NCMAX )GO TO 888 C NPTEST = 0 LPLMAX = 0 IERR = 0 NBP = 1 LIBPL = 2 IND(1) = 1 ICARD(1) = NCP JT(1) = 1 IFD(1) = -1 IFG(1) = -1 QTRIA(1) = 0.0 QMIN(1) = -1.0 IT(1) = 1 ITM(1) = 1 IPERE(1) = 0 DO 5 I=1,NCP ITPOLY(I) = IPOLYG(I) 5 CONTINUE ITPOLY(NCP+1) = IPOLYG(1) LIBTL = NCP+1 LIBTR = (NCP-2)*3 C C =============================================== C --- 1. BOUCLE SUR LES POLYGONES --- C =============================================== C C NBP : NOMBRE DE POLYGONES = NUMERO DU DERNIER POLYGONE C IPI : POLYGONE COURANT C ITP : ADRESSE DU POLY DANS ITPOLY C C 10 IPI = NBP ITP = IND(IPI) N = ICARD(IPI) J = JT(IPI) I = IT(IPI) C ------- POUR LE DEBUG ---------- C PRINT *,' ITPOLY(1)', C > (ITPOLY(II),II=1,NCP) LPLMAX = MAX(LIBPL,LPLMAX) NPTEST = NPTEST + 1 C C ---------------------------------- C --- ON A 1 TRIANGULATION DU POLY IPI --- C ---------------------------------- C IF((IFD(IPI).NE.-1).AND.(IFG(IPI).NE.-1))THEN IF(IFD(IPI).NE.0) > QTRIA(IPI)=MIN(QMIN(IFD(IPI)),QTRIA(IPI)) IF(IFG(IPI).NE.0) > QTRIA(IPI)=MIN(QMIN(IFG(IPI)),QTRIA(IPI)) C C --- ON A TROUVER UNE MEILLEURE TRIANGULATION --- C ------------------------------------------ C ON FUSIONNE LE TRIANGLE, LA TRIANGULATION DU SAG, C ET LA TRIANGULATION DU SAD. C IF(QTRIA(IPI) .GT. QMIN(IPI) )THEN K = ITM(IPI)-1 DO 15 II=1,3 ITRMIN(K+II) = ITRIA((I-1)*3+II) 15 CONTINUE IF(IFG(IPI).NE.0)THEN K = ITM(IPI) + 2 DO 16 II=1,(ICARD(IFG(IPI))-2)*3 ITRMIN(K+II)=ITRMIN(ITM(IFG(IPI))-1+II) 16 CONTINUE ENDIF C IF(IFD(IPI).NE.0)THEN IF(IFG(IPI).NE.0)THEN K = ITM(IPI) + 2 + (ICARD(IFG(IPI))-2)*3 ELSE K = ITM(IPI) + 2 ENDIF DO 17 II=1,(ICARD(IFD(IPI))-2)*3 ITRMIN(K+II)=ITRMIN(ITM(IFD(IPI))-1+II) 17 CONTINUE ENDIF QMIN(IPI) = QTRIA(IPI) C --- POUR LE DEBUG ---- C PRINT *,'---------------------------------------' C PRINT *,' TRIANGULATION RETENUE POUR LE POLYGON ',IPI C PRINT *,' PERE DE ',IFG(IPI),' ET ',IFD(IPI) C PRINT *,' ',(ITRMIN(ITM(IPI)-1+II),II=1,((N-2)*3)) C PRINT *,' QMIN ',QMIN(IPI) C PRINT *,' POLY = ',(ITPOLY(IND(IPI)+II-1),II=1,(ICARD(IPI))) C PRINT *,'---------------------------------------' ELSE C PRINT *,'---------------------------------------' C PRINT *,' TRIANGULATION NON RETENUE POUR LE POLYGON ',IPI C PRINT *,' PERE DE ',IFG(IPI),' ET ',IFD(IPI) C PRINT *,' S APPUYANT SUR = ',(ITRIA((I-1)*3+II),II=1,3) C PRINT *, QTRIA(IPI),' < ',QMIN(IPI) C PRINT *,' POLY = ',(ITPOLY(IND(IPI)+II-1),II=1,(ICARD(IPI))) C PRINT *,'---------------------------------------' ENDIF ENDIF C C =============================================== C --- 2. BOUCLE SUR LES TRIANGULATIONS D'UN POLYGONE C =============================================== C C ON PASSE AU TRIANGLE : ITP,IPT+1,J C 20 J=J+1 IF( J.GE.N )THEN C C -------------------------------------------- C --- ON A TOUTES LES TRIANGULATIONS DU POLY IPI --- C -------------------------------------------- C IF( IPERE(NBP).EQ.0 )THEN C C --- ON EST A LA RACINE : ON A FINI --- C -------------------------------- C DO 25 II=1,(ICARD(1)-2)*3 ITRPOL(II) = ITRMIN(ITM(1)-1+II) 25 CONTINUE QTMIN = QMIN(1) C --- POUR LE DEBUG ------------------------------- C PRINT *,' ITPOLY(IPI)',IPI,' = ', C > (ITPOLY(ITP+II-1),II=1,N) C PRINT *,' FILS D,G = ',IFD(IPI),IFG(IPI) C PRINT *,' ITRPOL(IPI)',IPI,' = ', C > (ITRPOL(II),II=1,((N-2)*3)) C PRINT *,(ITRPOL(II),II=1,((N-2)*3)) C PRINT *,' NOMBRE DE POLYS TESTES : ',NPTEST C PRINT *,' NOMBRE MAX DE POLYS EMPILES : ',LPLMAX GO TO 999 ENDIF C C PRINT *,' ITPOLY(IPI)',IPI,' = ', C > (ITPOLY(ITP+II-1),II=1,N) C PRINT *,' FILS D,G = ',IFD(IPI),IFG(IPI) C C --- ON CONTINUE LE PARCOURS --- C ------------------------ C IF((IFD(IPERE(IPI)).EQ.IPI).AND. > (IFG(IPERE(IPI)).NE.0))THEN C C --- ON VIENT DU SAD (FILS DROIT) --- C --- ON VA VISITER LE SAG (FILS GAUCHE) --- C -------------------------------- C NBP = IFG(IPERE(IPI)) IF( LIBPL.GT.(IPI+1))THEN C --- ON LIBERE LES FILS DU FILS DROIT --- LIBPL = IPI+1 LIBTR = ITM(IPI+1) C PRINT *,'LIBPL = ',LIBPL C PRINT *,'LIBTR = ',LIBTR C PRINT *,'LIBTL = ',LIBTL ENDIF ELSE C C --- BUG_21 : O.STAB 25.04.97 ------------------------------- C CAS SAG=0 PAS ENVISAGE : LIBTL = IND(IPI+2) C LIBTL PRENAIT DONC UNE MAUVAISE VALEUR (CELLE D'UN SAD) C QUE L'ON NE DOIT JAMAIS DESALLOUER (LIBTL) ! C C --- ON A FINI SAG ET SAD : ON REMONTE (AU PERE) --- C --------------------------------------------- C NBP = IPERE(IPI) C IF(IFG(IPERE(IPI)).EQ.0)THEN C --- ON VIENT DU SAD (FILS DROIT) ET LE SAG = 0 --- C PRINT *,'ON VIENT DU SAD (FILS DROIT) ET LE SAG = 0 ' IF( LIBPL.GT.(IPI+1))THEN C --- ON LIBERE LES FILS DU FILS DROIT --- LIBPL = IPI+1 LIBTR = ITM(IPI+1) ENDIF ENDIF IF(IFG(IPERE(IPI)).EQ.IPI)THEN C --- ON VIENT DU SAG (FILS GAUCHE) : ON A DEJA VISITE LE SAD --- C PRINT *,'ON VIENT DU SAG (FILS GAUCHE) ' IF( LIBPL.GT.(IPI+2))THEN C --- ON LIBERE LES FILS DU FILS GAUCHE--- C PRINT *,'IND = ',(IND(II),II=1,LIBPL-1) C PRINT *,'IPERE(IPI) = ',IPERE(IPI) C PRINT *,'IFD(IPERE(IPI)) = ',IFD(IPERE(IPI)) C PRINT *,'IFG(IPERE(IPI)) = ',IFG(IPERE(IPI)) LIBPL = IPI+2 LIBTR = ITM(IPI+2) LIBTL = IND(IPI+2) C PRINT *,'LIBPL = ',LIBPL C PRINT *,'LIBTR = ',LIBTR C IF( LIBTL.LT.NCP )THEN C PRINT *,'++++++++++++++++++++++++++++++++++++' C PRINT *,'IPI = ',IPI C PRINT *,'IPERE(IPI) = ',IPERE(IPI) C PRINT *,'IFD(IPERE(IPI)) = ',IFD(IPERE(IPI)) C PRINT *,'IFG(IPERE(IPI)) = ',IFG(IPERE(IPI)) C PRINT *,'LIBTL = IND(IPI+2)',LIBTL C PRINT *,'LIBPL = ',LIBPL C PRINT *,'LIBTR = ',LIBTR C ENDIF ENDIF ENDIF ENDIF C C --- ON A FINI LE PARCOURS DE L'ARBRE DU POLY NBP --- C GO TO 10 ENDIF C C ============================================== C --- ON CALCULE TOUTES LES TRIANGULATIONS CONTENANT C LE TRIANGLE ITP,ITP+1,ITP+J C ============================================== C QTRIA(IPI) = FCRMIN(X((ITPOLY(ITP )-1)*IDIMC+1), > X((ITPOLY(ITP+1)-1)*IDIMC+1), > X((ITPOLY(ITP+J)-1)*IDIMC+1), > IDIMC,RDONFR) C --------- POUR LE DEBUG ------------- C PRINT *,'POLYGON ',IPI,' ',IND(IPI),' ',ICARD(IPI), C > ' TRIANGLE ',ITPOLY(ITP),' ',(ITPOLY(ITP+1)), C > ' ',(ITPOLY(ITP+J)),' RIL = ',QTRIA(IPI) C C --- ON A PAS MIEUX : ON PASSE AU TRIANGLE SUIVANT (J=J+1) --- C IF( QTRIA(IPI) .LE. QMIN(IPI) ) GO TO 20 C ITRIA((I-1)*3+1) = ITPOLY(ITP) ITRIA((I-1)*3+2) = ITPOLY(ITP+1) ITRIA((I-1)*3+3) = ITPOLY(ITP+J) C C -------------------------- C --- ON STOQUE LE FILS GAUCHE --- C ITPOLY = IPT+J,.....,IPT C -------------------------- C IF( (N-J+1) .GT. 2 )THEN C --- ON DESCEND SUR LE FILS GAUCHE --- IF( LIBPL .EQ. NPMAX )GO TO 888 NBP = LIBPL IND(NBP) = LIBTL ICARD(NBP) = N-J+1 IFG(NBP) = -1 IFD(NBP) = -1 IPERE(NBP) = IPI JT(NBP) = 1 IT(NBP) = I+1+J-2 ITM(NBP) = LIBTR QMIN(NBP) = QMIN(IPI) QTRIA(NBP)= 0.0 IFG(IPI) = NBP C --- IF( ((NPMAX*NCMAX)-LIBTL) .LT. (N-J+1) )GO TO 888 C PRINT *,' LIBTL,N,J = ',LIBTL,N,J DO 30 II=0,(N-(J+1)) ITPOLY(LIBTL+II) = ITPOLY(ITP+J+II) 30 CONTINUE ITPOLY(LIBTL+N-J) = ITPOLY(ITP) LIBTL = LIBTL + ICARD(NBP) C PRINT *,' LIBTL = LIBTL + ICARD(NBP) ',LIBTL IF(((NPMAX*NCMAX)-LIBTR).LT.((ICARD(NBP)-2)*3))GO TO 888 LIBTR = LIBTR + ((ICARD(NBP)-2)*3) LIBPL = LIBPL + 1 ELSE IFG(IPI) = 0 ENDIF C C -------------------------- C --- ON STOQUE LE FILS DROIT --- C ITPOLY = IPT+1,.....,IPT+J C -------------------------- C IF( J .GE. 3 )THEN C --- ON DESCEND SUR LE FILS DROIT --- IF( LIBPL .EQ. NPMAX )GO TO 888 NBP = LIBPL IND(NBP) = ITP+1 ICARD(NBP) = J IFG(NBP) = -1 IFD(NBP) = -1 IPERE(NBP) = IPI JT(NBP) = 1 IT(NBP) = I+1 ITM(NBP) = LIBTR QMIN(NBP) = QMIN(IPI) QTRIA(NBP)= 0.0 IFD(IPI) = NBP IF(((NPMAX*NCMAX)-LIBTR).LT.((ICARD(NBP)-2)*3))GO TO 888 LIBTR = LIBTR + ((ICARD(NBP)-2)*3) LIBPL = LIBPL + 1 ELSE IFD(IPI) = 0 ENDIF C JT(IPI) = J C C --- ON TRAITE DANS L'ORDRE : IFD, IFG, IPERE C GOTO 10 C 888 IERR = -2 C 999 END C ********************************************************************** C MODULE : M4 (RAFFINEMENT D'UN MAILLAGE TRIANGULAIRE) C FICHIER : M4_DENSITE2D.F C OBJET : CALCUL DE LA DENSITE POUR RAFFINER C UNE TRIANGULATION DE DELAUNAY C FONCT. : C D2SUI : TAILLE SOUHAITE / SUITE DEFINIE EN UN OBJET C D2ISUI : CF D2SUI - FONCTION PARAMETRE C C AUTEUR : O. STAB C DATE : 07.95 C TESTS : 08.95 C MODIFICATIONS : C AUTEUR, DATE, OBJET : O.STAB, 19.06.98, BUG PROBABLE DANS LE CALCUL C DE LA TAILLE SOUHAITEE. A VERIFIER !!! C C REMARQUES : UN TRIANGLE EQUILATERAL : ARETE = SQRT(3)*RC C IL SEMBLE QUE L'ON AI DEFINI LA TAILLE D'UN TRIANGLE C COMME : TT = SQRT(3) RC C C ********************************************************************** C C SUBROUTINE D2SUI(XP1,XP2,XP3,XPC,VDIA,IDIMC, > ITYPS,TSP,RSG, > ITYPO,ROBJET,COEF,TS,IERR) C ***************************************************************** C OBJET : TAILLE SOUHAITE POUR UN TRIANGLE / CONCENTRATION DONNEE C C EN ENTREE : C XP1,XP2,XP3 : LES TROIS POINT DU TRIANGLE (INUTILISES) C XPC : UN POINT SUR LE CERCLE C VDIA : LE VECTEUR DIAMETRE PARTANT DE CE POINT C IDIMC : DIMENSION DE L'ESPACE C --------------------- C ITYPO : TYPE DE CONCENTRATION C ROBJET : LA DEFINITION GEOMETRIQUE DE LA CONCENTRATION C ITYPS : TYPE DE LA SUITE C TSP : LA TAILLE SOUHAITE A L'OBJET C RSG : RAISON DE LA SUITE GEOMETRIQUE C C EN SORTIE : C TS : TAILLE SOUHAITE POUR LE TRIANGLE XP1,XP2,XP3 C ELLE EST CALCULEE AVEC LA CONCENTRATION C COEF : A * TS / RC (RAYON DU CERCLE CIRCONSCRIT A IT) C "A" EST TEL QUE 0 <= COEF <=1 C PLUS COEF EST PETIT PLUS ON RAFFINE C IERR : CODE D'ERREUR 0 SI OK, C -1 SI TAILLE SOUHAITE EST NEGATIVE C OU SI LE RAYON CIRCONSCRIT EST NUL C REMARQUE : C LA TAILLE SOUHAITE EST EVALUEE AU CENTRE DU CERCLE C C NIVEAU : INTERFACE UTILISATEUR C ***************************************************************** INTEGER IDIMC,ITYPO,ITYPS REAL XP1(*),XP2(*),XP3(*) REAL XPC(*),VDIA(*),ROBJET(*),TSP,RSG,COEF,TS INTEGER IERR C REAL BARYC(3), VDD(3),DBARYC, TSBARY, DIAM, RC EXTERNAL XNORVE, NULLVE REAL XNORVE INTEGER NULLVE C REAL COEF3, XDEMI C --- COEF3 = 1/SQRT(3) ------------ DATA COEF3/.57735026918962576451/ XDEMI = 0.5 IERR = -1 C ================================================== C ------ TAILLE SOUHAITE AU CENTRE DE LA BOULE / DIAMETRE ------ C ================================================== CALL MUSCVE(VDIA,XDEMI,IDIMC,VDD) CALL SOMMVE(XPC,VDD,IDIMC,BARYC) CALL DIPOOB(IDIMC,BARYC,ITYPO,ROBJET,DBARYC,IERR) IF( IERR .NE. 0 ) THEN CALL DSERRE(1,IERR,'D2ISUI','APPEL DIPOOB') GOTO 999 ENDIF CALL SCSUPO(ITYPS,TSP,RSG,DBARYC,TSBARY) C --- MODIF O.STAB 19.06.98 BUG PROBABLE ?! C TSBARY = TSBARY * COEF3 IF( TSBARY.LE. 0.0 ) THEN IERR = -1 CALL DSERRE(1,IERR,'D2ISUI','TAILLE SOUHAITEE NEGATIVE') GOTO 999 ENDIF DIAM = XNORVE(VDIA,IDIMC) RC = DIAM * 0.5 IF( NULLVE(RC,1) .NE. 0 )THEN IERR = -1 CALL DSERRE(1,IERR,'D2ISUI','DIAMETRE NUL') GOTO 999 ENDIF C --- MODIF O.STAB 19.06.98 BUG PROBABLE ?! C COEF = TSBARY / RC COEF = COEF3 * TSBARY / RC TS = TSBARY IERR = 0 999 END C C SUBROUTINE D2ISUI(IT,ITRNOE,NBNMAX,ITRTRI,NBCMAX, > COORD,IDIMC,SPH,NBSMAX,ITAB,RTAB,COEF,TS,IERR) C **************************************************************** C OBJET : CALCULE LA TAILLE SOUHAITE / CONCENTRATION DONNEE C FONCTION PARAMETRE POUR RAF2D MODE ITERATIF C APPEL D2SUI C EN ENTREE : C --------- L'ELEMENT A RAFFINER ------------------- C IT : NUMERO DE L'ELEMENT A RAFFINER C ITRNOE,NBNMAX,ITRTRI,NBCMAX : LE MAILLAGE C ITRTRI,NBCMAX (INUTILISES) C COORD,IDIMC : COORDONNEES DANS L'ESPACE DE DIMENSION IDIMC C SPH,NBSMAX : VECTEUR DIAMETRE DES SPHERES CIRCONSCRITES C --------- DEFINITION DE LA CONCENTRATION ------------ C ITAB(1) : TYPE DE LA SUITE (1=GEOMETRIQUE, 2=ARITHEMTIQUE) C ITAB(2) : TYPE DE LA CONCENTRATION (1=POINT, 2=DROITE) C RTAB(1) : RAISON DE LA SUITE GEOMETRIQUE C RTAB(2) : TAILLE SOUHAITE A LA CONCENTRATION C RTAB(3...): COORDONNEES DES POINTS DEFINISSANT LA GEOMETRIE C DE LA CONCENTRATION : C - UN SEUL POINT SI ITAB(2) = 1 C - DEUX POINTS SI ITAB(2) = 2 C C EN SORTIE : C TS : TAILLE SOUHAITE POUR L'ELEMENT IT C ELLE EST DONNE PAR LA CONCENTRATION (ITAB,RTAB) C COEF : A * TS / RC (RAYON DU CERCLE CIRCONSCRIT A IT) C "A" EST TEL QUE 0 <= COEF <=1 C PLUS COEF EST PETIT PLUS ON RAFFINE C IERR : CODE D'ERREUR 0 SI OK, C -1 SI TAILLE SOUHAITE EST NEGATIVE C OU SI LE RAYON CIRCONSCRIT EST NUL C C NIVEAU : INTERFACE UTILISATEUR C **************************************************************** REAL COORD(*),SPH(*),COEF,TS INTEGER IT,ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX,NBSMAX INTEGER IDIMC,ITAB(*) REAL RTAB(*) INTEGER IERR C INTEGER NUMP1,NUMP2,NUMP3 C NUMP1 = ITRNOE((IT-1)*NBNMAX+1) NUMP2 = ITRNOE((IT-1)*NBNMAX+2) NUMP3 = ITRNOE((IT-1)*NBNMAX+3) CALL D2SUI(COORD((NUMP1-1)*IDIMC+1), > COORD((NUMP2-1)*IDIMC+1), > COORD((NUMP3-1)*IDIMC+1), > COORD((NUMP3-1)*IDIMC+1), > SPH((IT-1)*NBSMAX+1),IDIMC, > ITAB(1),RTAB(2),RTAB(1), > ITAB(2),RTAB(3),COEF,TS,IERR) C 999 END C C ***************************************************************** C MODULE : API LIBRAIRIE DELOS C FICHIER : API_TRIANGULATION.F C OBJET : TRIANGULATION DE DELAUNAY D'UN DOMAINE POLYGONAL C C FONCT. : C OBJET DSTRIA : TRIANGULE UN DOMAINE 2D (AVEC ARETES IMPOSES) C OBJET GNTRIA : TRIANGULE UN DOMAINE PSEUDO-PLAN ET MULTI-REGION C C AUTEUR : O.STAB C DATE : 21.07.99 C MODIFICATIONS : C AUTEUR, DATE, OBJET : O.STAB, 27.07.99, EXTRACTION DE DSTRIA2.F C ET SUPPRESSION DES E/S. C O.STAB, 17.09.2002, 2 BUG DANS L'ALLOCATION DES TABLEAUX (APPEL DSTRIA) C ***************************************************************** C SUBROUTINE DSTRIA(IDE1,ITRNO1,NBNMX1,NBN1,NBE1, > IFREEL,NFREEL, > COORD,IDIMC, > IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,NOEMAX, > NBN,NBE,NCC,NBPMAX,NBEMAX, > ITVL,NITMAX,RTVL,NRTMAX,ITRACE,IERR) C ********************************************************************** C OBJET DSTRIA : TRIANGULE UN DOMAINE 2D (AVEC ARETES IMPOSES) C C EN ENTREE : C ----------- FRONTIERE DU DOMAINE A MAILLER ----------- C ITRNO1 : NOEUDS DES ELEMENTS DE LA FRONTIERE C NBNMX1 : NOMBRE DE NOEUDS PAR ELEMENT C NBE1 : NOMBRE D'ELEMENTS C NBN1 : NOMBRE DE NOEUDS C IFREEL,NFREEL ??? C COORD : COORDONNEES DES NOEUDS C NBPMAX : NOMBRE MAXIMUM DE POINTS (DANS COORD) C NBEMAX : NOMBRE MAXIMUM D'ELEMENT (DANS LE MAILLAGE) C C ITRACE : DESUET ! C C EN SORTIE : C ----------- LE MAILLAGE TRIANGULAIRE ------------------ C IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,NOEMAX,NBN,NBE,NCC : C C IERR : CODE D'ERREUR C 0 : OK, LE MAILLAGE EST VALIDE C -1 : UNE ERREUR EST SURVENUE (DONNEES INCORRECTE) C -2 : PAS ASSEZ DE MEMOIRE (LE MAILLAGE N'EST PAS GENERE) C ********************************************************************** INTEGER IDE1,ITRNO1(*),NBNMX1,NBN1,NBE1 INTEGER IFREEL,NFREEL REAL COORD(*) INTEGER IDIMC INTEGER IDE,ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX,NOETRI(*),NOEMAX INTEGER NBN,NBE,NCC,NBPMAX,NBEMAX INTEGER ITVL(*) REAL RTVL(*) INTEGER NITMAX,NRTMAX,ITRACE,IERR C INTEGER ITRAV,NITMX2,IRTRAV,NRTMX2,I INTEGER NBARET,IERRI,NBENEW,NBARFR C ITRAV = 1 IRTRAV = 1 NITMX2 = NITMAX - ITRAV + 1 NRTMX2 = NRTMAX - IRTRAV + 1 C C ===================================== C ---- 1. TRIANGULATION DU NUAGE DE POINTS ---- C ===================================== C IF(ITRACE.GT.0)CALL ESECHA(1,'-> TRIANGULATION DU CONVEXE',' ') IDE = IDIMC NBNMAX = IDE + 1 NBCMAX = NBNMAX NBN = NBN1 CALL TRNUPO(COORD,NBN,ITRNOE, > NBNMAX,ITRTRI,NBCMAX,NOETRI,NBE, > ITVL(ITRAV),NITMX2,RTVL(IRTRAV),IERR) IF(IERR.NE.0)THEN CALL DSERRE(1,IERR,'DSTRIA',' APPEL TRNUPO') CALL DSERRE(1,IERR,'LA TRIANGULATION ', > ' POINTS CONFONDUS PROBABLEMENT') GOTO 9999 ENDIF C IF( ITRACE.GT.0 )THEN C CALL ESEINT(1,'NOMBRE DE NOEUDS : ',NBN,1) C CALL ESEINT(1,'NOMBRE DE TRIANGLES : ',NBE,1) C ENDIF C --- POUR LE DEBUG --- C CALL SDBTRI(IDE,ITRNOE,NBNMAX,ITRTRI, C > NBCMAX,NOETRI,NBE, C > NBN,ITRACE,IERR) C IF( IERR .NE. 0 )THEN C CALL DSERRE(1,IERR,'SDBTRI','APRES TRNUPO') C GO TO 9999 C ENDIF C C ================================== C --- 2. FORCAGE DES ARETES FRONTIERES --- C ================================== 100 CONTINUE IF( NBE1.EQ. 0 )GOTO 9999 C IF(ITRACE.GT.0)CALL ESECHA(1,'-> RESPECT DE LA FRONTIERE',' ') C IERRI = 0 NBARET = NBE1 NBARFR = 0 DO 110 I=1,NBARET CALL RF2RAR(ITRNO1((I-1)*NBNMX1+1), > ITRNOE,NBNMAX, > ITRTRI,NBCMAX,NOETRI,NBE, > COORD,ITVL(ITRAV),NITMX2, > RTVL(IRTRAV),NRTMX2, > NBENEW,IERR) C --- POUR LE DEBUG --- C CALL SDBTRI(IDE,ITRNOE,NBNMAX,ITRTRI, C > NBCMAX,NOETRI,NBE, C > NBN,ITRACE,IERR) IF( IERR .NE. 0 )THEN CALL DSERRE(1,IERR,'DSTRIA',' APPEL RF2RAR') C CALL DSERRE(1,IERR,'FRONTIERE ', C > ' FRONTIERE CROISEE ?') C CALL ESEINT(1,'ERREUR POUR L ARETE : ',I,1) IERRI = IERR IERR = 0 ENDIF IF(NBENEW.GT. 0 )NBARFR = NBARFR + 1 110 CONTINUE C IF(IERRI.NE.0)THEN CALL DSERRE(1,IERRI,'DSTRIA',' APPEL RF2RAR') IERR = IERRI GOTO 9999 ENDIF C IF(ITRACE.GT.0)THEN C IF(NBARFR.GT.0)THEN C CALL ESEINT(1,'NOMBRE D ARETES FORCEES : ',NBARFR,1) C ELSE C CALL ESECHA(1,'LA TRIANGULATION RESPECTE DELAUNAY',' ') C ENDIF C ENDIF C C ================================================ C --- 4. DESTRUCTION DES ELEMENTS EXTERIEURS : SCULPT --- C ================================================ 300 CONTINUE C IF(ITRACE.GT.0)CALL ESECHA(1, C > '-> DESTRUCTION DES ELEMENTS EXTERIEURS',' ') C CALL SCULPT(ITRNO1((IFREEL-1)*NBNMX1+1),NBNMX1,NFREEL, > IDE,ITRNOE,NBNMAX, > ITRTRI,NBCMAX,NOETRI, > NBE,ITVL(ITRAV),NITMX2,NCC,IERR) C C --- POUR LE DEBUG --- C CALL SDBTRI(IDE,ITRNOE,NBNMAX,ITRTRI, C > NBCMAX,NOETRI,NBE, C > NBN,ITRACE,IERR) IF( IERR .NE. 0 )THEN CALL DSERRE(1,IERR,'DSTRIA',' APPEL SCULPT') CALL DSERRE(1,IERR,' LE DOMAINE', > ' FRONTIERE INCORRECTE') GO TO 9999 ENDIF C C ========================================= C --- 4. INSERTION DES FRONTIERES INTERIEURES --- C ========================================= 400 CONTINUE C AJOUT 26.01.99 ITRAV = 1 NITMX2 = NITMAX DO 410 I=1,NBE1 CALL SFRICR(ITRNO1((I-1)*NBNMX1+1),NBNMX1, > IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX, > NOETRI,NBE,ITVL(ITRAV),NITMX2,IERR) IF( IERR.NE. 0 )THEN CALL DSERRE(1,IERR,'DSTRIA',' APPEL SFRICR') IERR = 0 C il faudrait des messages !!! et pouvoir continuer C GOTO 9999 ENDIF 410 CONTINUE C 9999 END C C SUBROUTINE GNTRIA(IDE1,IARETE,NBNMX1,NBN1,NBARET, > COORDO,IDIMC, > IMTRF1,INTMA1,NMT1, C --- EN SORTIE : > IDE,ITRNOE,NBNMAX, > NBN,NBE,NCC,NBPMAX,NBEMAX, > IMTREF,NMTREF,INTMAT,INTMAX,NMT, > ITVL,NITMAX,RTVL,NRTMAX,ITRACE,IERR) C ********************************************************************** C OBJET GNTRIA : TRIANGULE UN DOMAINE PSEUDO-PLAN ET MULTI-REGION C APPEL DSTRIA + PROJECTION + GESTION DES REGIONS C EN ENTREE : C C NMTREF : TAILLE DE IMTREF C INTMAX : TAILLE DE INTMAX C C ITVL : TABLEAU D'ENTIERS POUR LES CALCULS C NITMAX : TAILLE DE ITVL C RTVL : TABLEAU DE REELS POUR LES CALCULS C NRTMAX : TAILLE DE RTVL (12 (NBP+12)) C ITRACE : DESUET ! C EN SORTIE : C IERR : CODE D'ERREUR -1 SI DONNEES INCORRECTES C -2 SI TABLEAUX INSUFFISANTS C ********************************************************************** INTEGER IDE1,IARETE(*),NBNMX1,NBN1,NBARET REAL COORDO(*) INTEGER IDIMC,IMTRF1(*),INTMA1(*),NMT1 INTEGER IDE,ITRNOE(*),NBNMAX INTEGER NBN,NBE,NCC,NBPMAX,NBEMAX INTEGER IMTREF(*),NMTREF,INTMAT(*),INTMAX,NMT INTEGER ITVL(*) REAL RTVL(*) INTEGER NITMAX,NRTMAX,ITRACE,IERR C C --- VARIABLES INTERNES --- INTEGER NBCMAX INTEGER ITRTRI,NOETRI,NOEMAX INTEGER ITRIRG,NRGMAX,IMAT,NMAT,NR1MAX INTEGER IFREEL,NFREEL INTEGER ITRAV,IRTRAV,NITMX2,NRTMX2,MAJNOE C ---- MODIF POUR LA PROJECTION --- INTEGER IDIMC2,ICOO2D,IORIG,IMATT,IND1,IND2,IPOINT(1),NPOINT INTEGER I,J C --- NOM DE REGION PAR DEFAUT INTEGER MATDEF PARAMETER (MATDEF = 1 ) C ITRAV = 1 IRTRAV = 1 NITMX2 = NITMAX - ITRAV + 1 NRTMX2 = NRTMAX - IRTRAV + 1 C =========================== C --- 1. FRONTIERE DES DOMAINES --- C =========================== IMAT = ITRAV C ---- AU CAS OU IL N'Y A PAS DE REGION ---- ITRAV = IMAT + MAX(2*NBARET, 1) NITMX2 = NITMAX - ITRAV + 1 C NR1MAX = 0 CALL DFR2FR(IDE1,IARETE,NBNMX1,NBARET, > ITVL(ITRAV),NR1MAX, > IMTRF1,NMT1,INTMA1,NMT1, > ITVL(IMAT),IFREEL,NFREEL,NMAT, > ITVL(ITRAV),NITMX2,IERR) NMT1 = NMAT C IF( IERR.NE.0 )THEN CALL DSERRE(1,IERR,'GNTRIA','APPEL DFR2FR') GOTO 9999 ENDIF C ---- LE REGION PAR DEFAUT EST "1" ---- IF( NBARET.EQ. 0 )THEN ITVL(IMAT) = MATDEF NMT1 = 1 ENDIF C ==================================================== C ---- 0. PROJECTION SUR LE PLAN DES MOINDRES CARRES SI 3D --- C ==================================================== IDIMC2 = 2 IF(IDIMC.EQ.3 )THEN ICOO2D = IRTRAV IORIG = ICOO2D + NBPMAX*IDIMC2 IMATT = IORIG + 3 IRTRAV = IMATT + 9 C NRTMX2 = NITMAX - IRTRAV , BUG 080699: NRTMX2 = NRTMAX - IRTRAV IND1 = 1 IND2 = NBN1 IPOINT(1) = 0 NPOINT = 0 CALL RPPNCR(IPOINT,NPOINT,IND1,IND2, > COORDO,IDIMC, > ITVL(ITRAV),NITMX2,RTVL(IRTRAV),NRTMX2, > RTVL(IORIG),RTVL(IMATT),RTVL(ICOO2D),IDIMC2,IERR) C ---- POUR LE DEBUG ---- PRINT *,'GNTRIA: ORIG = ',RTVL(IORIG),RTVL(IORIG+1),RTVL(IORIG+2) DO 998 I=1,MIN(NBN1,10) PRINT *,(RTVL((I-1)*IDIMC2+ICOO2D+J-1),J=1,IDIMC2) 998 CONTINUE IF( IERR.NE.0 )THEN CALL DSERRE(1,IERR,'GNTRIA','APPEL RPPNCR') GOTO 9999 ENDIF IRTRAV = IORIG C NITMX2 = NITMAX - IRTRAV BUG 080699 : C NRTMX2 = NITMAX - IRTRAV 2ieme BUG !!!! 01.07.99 OS NRTMX2 = NRTMAX - IRTRAV ENDIF C ---------------- C --- 2.1 ALLOCATION --- C ---------------- C ITVL = |IARETE|IMAT| ITRNOE | ITRTRI | NOETRI | ITRAV C NBEMAX*3 NBEMAX*3 NBPMAX 310 C TRNUPO C IDE = IDIMC BUG 080699 : C IDE = IDE1 + 1 BUG 17.09.2002 IDE = 2 NBNMAX = IDE + 1 NBCMAX = NBNMAX NBE = 0 C ITRTRI = ITRAV + (NBEMAX * NBNMAX) BUG 17.09.2002 ITRTRI = ITRAV NOETRI = ITRTRI + (NBEMAX * NBCMAX) ITRAV = NOETRI + NBPMAX NITMX2 = NITMAX - ITRAV C -------------------------------------------- C --- 2.2 CALCUL DE LA TRIANGULATION DE DELAUNAY --- C -------------------------------------------- C --- LA GESTION DES REGIONS EST A L'EXTERIEUR DE DSTRIA --- C NRGMAX = 0 C NMTREF = 0 BUG 02.07.99 C ITRIRG = 1 IF(IDIMC.EQ.3)THEN CALL DSTRIA(IDE1,IARETE,NBNMX1,NBN1,NBARET, > IFREEL,NFREEL, > RTVL(ICOO2D),IDIMC2, > IDE,ITRNOE,NBNMAX, > ITVL(ITRTRI),NBCMAX,ITVL(NOETRI),NOEMAX, > NBN,NBE,NCC,NBPMAX,NBEMAX, > ITVL(ITRAV),NITMX2,RTVL(IRTRAV),NRTMX2,ITRACE,IERR) ELSE CALL DSTRIA(IDE1,IARETE,NBNMX1,NBN1,NBARET, > IFREEL,NFREEL, > COORDO,IDIMC2, > IDE,ITRNOE,NBNMAX, > ITVL(ITRTRI),NBCMAX,ITVL(NOETRI),NOEMAX, > NBN,NBE,NCC,NBPMAX,NBEMAX, > ITVL(ITRAV),NITMX2,RTVL(IRTRAV),NRTMX2,ITRACE,IERR) ENDIF C IF( IERR.NE. 0)THEN CALL DSERRE(1,IERR,'GNTRIA','APPEL A DSTRIA') GOTO 9999 ENDIF C ========================================= C --- 5. AFFECTATION DES REGIONS --- C ========================================= ITRIRG = ITRAV NRGMAX = NBE ITRAV = ITRIRG + NRGMAX NITMX2 = NITMAX - ITRAV MAJNOE = 0 CALL DFR2RG(IDE1,IARETE,NBNMX1,NBARET, > ITVL(IMAT),NMT1, > IDE,ITRNOE,NBNMAX, > ITVL(ITRTRI),NBCMAX,ITVL(NOETRI),NOEMAX,NBE, > MAJNOE, > ITVL(ITRIRG),NRGMAX,IMTREF,NMTREF, > INTMAT,INTMAX,NMT, > ITVL(ITRAV),NITMX2,IERR) C IF( IERR.NE. 0)THEN CALL DSERRE(1,IERR,'GNTRIA','APPEL A DFR2RG') GOTO 9999 ENDIF C 9999 END C ***************************************************************** C MODULE : C FICHIER : API_MESH.F (anciennement DSG_NEW.f) C OBJET : MAILLAGE EN TRIANGLE D'UN DOMAINE SURFACIQUE (MULTI-REGION) C fonction appellees de Delos C C FONCT. : C OBJET DSTRAF : TRIANGULATION ET RAFFINEMENT D'UN DOMAINE PLAN (2D ou 3D) MONO-REGION C OBJET RGARET : EXTRAIT LES ARETES D'UNE REGION C OBJET RGRAFT : MAILLAGE ET RAFFINEMENT DE LA REGION IREGIO, C C AUTEUR : O.STAB C DATE : 21.07.99 C MODIFICATIONS : C AUTEUR, DATE, OBJET : O.STAB, 05.03.2001 CORRECTION BUG DS RGRAFT C AUTEUR, DATE, OBJET : O.STAB, 07.06.2001 CORRECTION "BUG" DS RGARET C C A FAIRE : DSTRAF ET RGRAFT SONT A DESCENDRE DANS DELOS API_MESH.F... C ***************************************************************** C SUBROUTINE DSTRAF(IDE1,IARETE,NBNMX1,NBN1,NBARET, > IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,NOEMAX, > NBN,NBE,NCC,NBPMAX,NBEMAX, > COORD,IDIMC, > GRDNOE,NGRDMX, > MODDEF,MODGEN,NBPNEW, > IADEC,NIADEC,RADEC,NRIDEC,NFADEC, > ITVL,NITMAX,RTVL,NRTMAX,ITRACE,IERR) C ********************************************************************** C OBJET DSTRAF : TRIANGULATION ET RAFFINEMENT D'UN DOMAINE PLAN (2D ou 3D) MONO-REGION C C EN ENTREE : C --- LE MAILLAGE LINEIQUE --- C IDE1,IARETE,NBNMX1,NBN1,NBARET : LE MAILLAGE LINEIQUE C COORD,IDIMC : LES POINTS DU MAILLAGE LINEIQUE C C ---- DEFINITION DU RAFFINEMENT -------------- C MODDEF : IL Y A 3 TYPES DE DEFINITIONS C 1 LE MODE DEFAUT SIMPLE C 2 LE MODE CONCENTRATIONS(X,Y) C 3 LE MODE VALEURS NODALES C MODGEN : IL Y A 3 MODES DE GENERATION C 1 LE MODE DIRECT C 2 LE MODE ITERATIF C 3 LE MODE ITERATIF + LISSAGE C NBPNEW : NOMBRE MAXIMUM DE POINTS A GENERER C C IADEC((I-1)*NIADEC+1) : PARAMETRES ENTIERS DU IEME RAFFINEMENT C NIADEC : NOMBRE MAX. DE PARAMETRES ENTIERS C RADEC((I-1)*NIADEC+1) : PARAMETRES REELS DU IEME RAFFINEMENT C NRIDEC : NOMBRE MAX. DE PARAMETRES REELS C NFADEC : NOMBRE DE RAFFINEMENTS C C EN SORTIE : C ---- LIMITATION DONNE PAR L'UTILISATEUR --- C IERR = 2 : NOMBRE MAXIMUM D ELEMENTS ATTEINT: C IERR = 1 : NOMBRE MAXIMUM DE NOEUDS ATTEINT: C IERR = 0 : TAILLE SOUHAITEE ATTEINTE (FRONTIERE): ' C C REMARQUE : APPEL DSTRIA ET DSRAFT C C LIMITATIONS : CONCENTRATIONS PONCTUELLES ET AXIALES C LES POINTS AJOUTES SONT DANS LE PLAN DES MOINDRES CARRES C ********************************************************************** INTEGER IDE1,IARETE(*),NBNMX1,NBN1,NBARET INTEGER IDE,ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX,NOETRI(*),NOEMAX INTEGER NBN,NBE,NCC,NBPMAX,NBEMAX REAL COORD(*),GRDNOE(*) INTEGER IDIMC,NGRDMX INTEGER ITVL(*) REAL RTVL(*),RADEC(*) INTEGER MODDEF,MODGEN,NBPNEW,IADEC(*),NFADEC,NIADEC,NRIDEC INTEGER NITMAX,NRTMAX,ITRACE,IERR C ---- MODIF POUR LA PROJECTION --- INTEGER IDIMC2,ICOO2D,IORIG,IMATT,IND1,IND2,IPOINT(1),NPOINT INTEGER I,J C INTEGER ITRAV,NITMX2,IRTRAV,NRTMX2 INTEGER IUN,NMT2 INTEGER NDECMX INTEGER INODE,NBN2 C INTEGER IFREEL,NFREEL C INODE = 0 IUN = 1 ITRAV = 1 NITMX2 = NITMAX IRTRAV = 1 NRTMX2 = NRTMAX C --- PAS DE FRONTIERE INTERIEUR A PRIORI ! --- IFREEL = 1 NFREEL = NBARET C INODE = 0 C ------------------- C --- CAS D'UN DOMAINE 3D --- C ------------------- IF( IDIMC.EQ.3 )THEN C ---- PROJECTION SUR LE PLAN DES MOINDRES CARRES SI 3D --- IDIMC2 = 2 ICOO2D = IRTRAV IORIG = ICOO2D + NBPMAX*IDIMC2 IMATT = IORIG + 3 IRTRAV = IMATT + 9 NRTMX2 = NRTMAX - IRTRAV IND1 = 1 IND2 = NBN1 IPOINT(1) = 0 NPOINT = 0 CALL RPPNCR(IPOINT,NPOINT,IND1,IND2, > COORD,IDIMC, > ITVL(ITRAV),NITMX2,RTVL(IRTRAV),NRTMX2, > RTVL(IORIG),RTVL(IMATT),RTVL(ICOO2D),IDIMC2,IERR) C ---- POUR LE DEBUG ---- C ORIG : NOUVELLE ORIGINE C IMATT : MATRICE 3x3 DE PASSAGE DANS LE NOUVEAU REPERE C PRINT *,'DSTRAF: ORIG = ',RTVL(IORIG),RTVL(IORIG+1),RTVL(IORIG+2) C DO 60 I=1,MIN(NBN,10) C PRINT *,(RTVL((I-1)*IDIMC2+ICOO2D+J-1),J=1,IDIMC2) C 60 CONTINUE IF( IERR.NE.0 )THEN CALL DSERRE(1,IERR,'DSTRAF','APPEL RPPNCR') GOTO 9999 ENDIF C --- ATTENTION NE RIEN LIBERER CA SERT PLUS LOIN !!! C IRTRAV = IORIG C NRTMX2 = NRTMAX - IRTRAV C ENDIF C... a integrer CALL DSTRIA(IDE1,IARETE,NBNMX1,NBN1,NBARET, > IFREEL,NFREEL, > RTVL(ICOO2D),IDIMC2, > IDE,ITRNOE,NBNMAX, > ITRTRI,NBCMAX,NOETRI,NOEMAX, > NBN,NBE,NCC,NBPMAX,NBEMAX, > ITVL(ITRAV),NITMX2,RTVL(IRTRAV),NRTMX2,ITRACE,IERR) IF( IERR.NE.0 )THEN CALL DSERRE(1,IERR,'DSTRAF','APPEL DSTRIA') GOTO 9999 ENDIF C C --- ATTENTION LES CONCENTRATIONS PONCTUELLE ET AXIALES NE PASSERONT PAS EN 3D C NBN2 = NBN CALL DSRAFT(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX, > NOETRI,NOEMAX, > NBN2,NBE,NCC,NBPMAX,NBEMAX, > RTVL(ICOO2D),IDIMC2, > GRDNOE,NGRDMX, > MODDEF,MODGEN,NBPNEW, > IADEC,NIADEC,RADEC,NRIDEC,NFADEC, > ITVL(ITRAV),NITMX2,RTVL(IRTRAV),NRTMX2,ITRACE,IERR) C C ---- LIMITATION DONNE PAR L'UTILISATEUR --- C IERR = 2 : NOMBRE MAXIMUM D ELEMENTS ATTEINT: C IERR = 1 : NOMBRE MAXIMUM DE NOEUDS ATTEINT: C IERR = 0 : TAILLE SOUHAITEE ATTEINTE (FRONTIERE): ' IF( IERR.LT.0 )THEN CALL DSERRE(1,IERR,'DSTRAF','APPEL DSRAFT') GOTO 9999 ENDIF C PRINT *,'APRES DSRAFT INODE = ',IERR INODE = IERR IERR = 0 C --- INTERPOLATION DES POINTS CALCULES 2D -> 3D C YMAT(3,3) = RTVL(IMAT) C CALL M33INV(YMATT,XMATT,IERR) CALL M33INV(RTVL(IMATT),RTVL(IMATT),IERR) IF( IERR.NE. 0 )THEN CALL DSERRE(1,IERR,'GNRAFT','APPEL M33INV') GOTO 9999 ENDIF C C PRINT *,'ON PROJETE LES POINTS GENERES ',NBN2-NBN DO 70 I=(NBN+1),NBN2 C --- LES POINTS GENERES SERONT SUR LE PLAN MOYEN COORD((I-1)*IDIMC+1) = RTVL((I-1)*IDIMC2+ICOO2D) COORD((I-1)*IDIMC+2) = RTVL((I-1)*IDIMC2+ICOO2D+1) COORD((I-1)*IDIMC+3) = 0.0 C CALL SOMMVE(COORD((I-1)*IDIMC+1),RTVL(IORIG),IDIMC, C > COORD((I-1)*IDIMC+1)) CALL M33APP(RTVL(IMATT),COORD((I-1)*IDIMC+1),IDIMC,IUN, > RTVL(IRTRAV),COORD((I-1)*IDIMC+1)) CALL SOMMVE(COORD((I-1)*IDIMC+1),RTVL(IORIG),IDIMC, > COORD((I-1)*IDIMC+1)) 70 CONTINUE NBN = NBN2 C ELSE C ------------------- C --- CAS D'UN DOMAINE 2D --- C ------------------- C C... a integrer CALL DSTRIA(IDE1,IARETE,NBNMX1,NBN1,NBARET, > IFREEL,NFREEL, > COORD,IDIMC, > IDE,ITRNOE,NBNMAX, > ITRTRI,NBCMAX,NOETRI,NOEMAX, > NBN,NBE,NCC,NBPMAX,NBEMAX, > ITVL(ITRAV),NITMX2,RTVL(IRTRAV),NRTMX2,ITRACE,IERR) C IF( IERR.NE.0 )THEN CALL DSERRE(1,IERR,'DSTRAF','APPEL DSTRIA') GOTO 9999 ENDIF C CALL DSRAFT(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX, > NOETRI,NOEMAX, > NBN,NBE,NCC,NBPMAX,NBEMAX, > COORD,IDIMC, > GRDNOE,NGRDMX, > MODDEF,MODGEN,NBPNEW, > IADEC,NIADEC,RADEC,NRIDEC,NFADEC, > ITVL(ITRAV),NITMX2,RTVL(IRTRAV),NRTMX2,ITRACE,IERR) C IF( IERR.LT.0 )THEN CALL DSERRE(1,IERR,'DSTRAF','APPEL DSRAFT') GOTO 9999 ENDIF C PRINT *,'APRES DSRAFT INODE = ',IERR INODE = IERR IERR = 0 ENDIF C IERR = INODE C 9999 END C C --- SEPARATION DE CHAQUE REGION ! C SUBROUTINE RGARET(IDE1,IARETE,NBNMX1,NBN1,NBARET, > IAR2RG,NBRGMX,IREGIO, > ISOMRG,NBSORG,NSOMAX,IARERG,NBARRG,NARMAX, > ITVL,NITMAX,RTVL,NRTMAX,ITRACE,IERR) C ********************************************************************** C OBJET RGARET : EXTRAIT LES ARETES D'UNE REGION C EN ENTREE : C IDE1,IARETE,NBNMX1,NBN1,NBARET : LE MAILLAGE LINEIQUE C C NBRGMX : NOMBRE MAXIMUM DE REGIONS INCIDENTES A UNE ARETE C IAR2RG((I-1*NBRGMX+J) : Jeme REGION INCIDENTE A L'ARETE I C IREGIO : NUMERO DE LA REGION RECHERCHEE C C EN SORTIE : C ISOMRG : TABLEAU DES SOMMETS DE LA REGION C IARERG : TABLEAU DES ARETES DE LA FRONTIERE DE LA REGION C ********************************************************************** INTEGER IDE1,IARETE(*),NBNMX1,NBN1,NBARET INTEGER IAR2RG(*),NBRGMX,IREGIO INTEGER ISOMRG(*),NBSORG,NSOMAX,IARERG(*),NBARRG,NARMAX INTEGER ITVL(*) REAL RTVL(*) INTEGER NITMAX,NRTMAX,ITRACE,IERR C INTEGER I,J C NBSORG = 0 NBARRG = 0 DO 100 I=1,NBARET C IF((IAR2RG((I-1)*2+1).EQ.IREGIO ).OR. C > (IAR2RG((I-1)*2+2).EQ.IREGIO))THEN DO 50 J=1,NBRGMX IF(IAR2RG((I-1)*NBRGMX+J).EQ.IREGIO )THEN C --- COPIE DES SOMMETS ET DE L'ARETE C IF((NBSORG+2.GT.NSOMAX).OR.(NBARRG+1.GT.NARMAX))THEN IF((NBSORG+2.GT.NSOMAX*2).OR.(NBARRG+1.GT.NARMAX))THEN IERR = -2 GOTO 9999 ENDIF NBSORG = NBSORG+1 ISOMRG(NBSORG)=IARETE((I-1)*NBNMX1+1) C --- ajout 10.01.2005 pour les sommets isoles IF(( IARETE((I-1)*NBNMX1+2).EQ.0 ).OR.(NBNMX1.EQ.1))GOTO 100 NBSORG = NBSORG+1 ISOMRG(NBSORG)=IARETE((I-1)*NBNMX1+2) NBARRG = NBARRG+1 IARERG((NBARRG-1)*2+1)=IARETE((I-1)*NBNMX1+1) IARERG((NBARRG-1)*2+2)=IARETE((I-1)*NBNMX1+2) C ON POURRAIT FAIRE UN GOTO 100 C MODIF 07.06.2001 O.STAB : NE STOQUE QU'UNE SEULE FACE C (EVITE UN PLANTAGE QUAND LA FACE EST REPETEE !) GOTO 100 ENDIF 50 CONTINUE 100 CONTINUE C --- ON TRIE LES SOMMETS C CALL TBVTAB(ITABRG,NBE,ITVL,IREFRG,NBREF, C > NREFMX,IERR) C RENVOI LES VALEURS DISTINCTES ET TRIEES D'UN TABLEAU, C TRIEES DANS L'ORDRE CROISSANT CALL TBVTAB(ISOMRG,NBSORG,ITVL,ISOMRG,NBSORG,NSOMAX,IERR) IF(IERR.NE.0)THEN CALL DSERRE(1,IERR,'RGARET','APPEL TBVTAB') GOTO 9999 ENDIF C 9999 END C C C SUBROUTINE RGRAFT(IDE1,IARETE,NBNMX1,NBN1,NBARET, C > IAR2RG,IREGIO, > IAR2RG,NBRGMX,IREGIO, C > IDE,ITRNOE,NBNMAX, C INUTILE POUR L'INSTANT : ITRTRI,NBCMAX,NOETRI,NOEMAX, > NBN,NBE,NCC,NBPMAX,NBEMAX, > COORD,IDIMC, C > GRDNOE,NGRDMX, > MODDEF,MODGEN,NBPNEW, > IADEC,NIADEC,RADEC,NRIDEC,NFADEC, > ITVL,NITMAX,RTVL,NRTMAX,ITRACE,IERR) C ********************************************************************** C OBJET RGRAFT : MAILLAGE ET RAFFINEMENT DE LA REGION IREGIO, C AVEC AJOUT AU MAILLAGE EXISTANT C C EN ENTREE : C --- LE MAILLAGE LINEIQUE --- C IDE1,IARETE,NBNMX1,NBN1,NBARET : LE MAILLAGE LINEIQUE C IAR2RG,NBRGMX : REGIONS INCIDENTES AUX ARETES C COORD,IDIMC : LES POINTS DU MAILLAGE LINEIQUE C C --- LE RAFFINEMENT SOUHAITE --- C MODDEF,MODGEN,NBPNEW, C IADEC,NIADEC,RADEC,NRIDEC,NFADEC, C C EN SORTIE : C ---- LIMITATION DONNE PAR L'UTILISATEUR --- C IERR = 2 : NOMBRE MAXIMUM D ELEMENTS ATTEINT: C IERR = 1 : NOMBRE MAXIMUM DE NOEUDS ATTEINT: C IERR = 0 : TAILLE SOUHAITEE ATTEINTE (FRONTIERE): C LIMITATIONS : CONCENTRATIONS PONCTUELLES ET AXIALES C LES POINTS AJOUTES SONT DANS LE PLAN DES MOINDRES CARRES C REMARQUE : C CUMULE DSTRIA ET DSRAFT POUR UNE REGION DONNE: IREGIO C TRIANGULATION D'UN DOMAINE SURFACIQUE (PAS FORCEMENT PLAN) C ET RAFFINEMENT (CAS MULTI-MATERIAUX) C ********************************************************************** INTEGER IDE1,IARETE(*),NBNMX1,NBN1,NBARET INTEGER IAR2RG(*),NBRGMX,IREGIO INTEGER IDE,ITRNOE(*),NBNMAX C ITRTRI(*),NBCMAX,NOETRI(*),NOEMAX INTEGER NBN,NBE,NCC,NBPMAX,NBEMAX REAL COORD(*) INTEGER IDIMC REAL GRDNOE(*) INTEGER NGRDMX INTEGER MODDEF,MODGEN,NBPNEW INTEGER IADEC(*),NIADEC REAL RADEC(*) INTEGER NRIDEC,NFADEC REAL RTVL(*) INTEGER ITVL(*),NITMAX,NRTMAX,ITRACE,IERR C --- VARIABLES LOCALES --- INTEGER I,J,K,NBSORG,NBARRG INTEGER ITRAV,IRTRAV,NITMX2,NRTMX2 INTEGER ISOMRG,NSOMRG,NSOMAX,IARERG,NARMAX INTEGER ICOOM,OLDNUM,INEWNU,NEWNUM,IARMA,NBETR INTEGER IGRDMX,NBGRD,IRADEC,NRADEC,NBTSN,NBTSMX INTEGER PSTRUC,PITRRG,TSN,ICOEF,IDIMG,NBPMX2,NBEMX2 INTEGER IRGNOE,IRGTRI,IRGNOT,NOEMX2,NBNRG,NBERG,NCCRG INTEGER NBNMX3,NBCMX3 INTEGER NBPTOT,INODE INTEGER NUMNOD,NEWNOD C * pour tester la memoire : ITVL(NITMAX-1) = 0 * INODE = 0 ITRAV = 1 IRTRAV = 1 NRTMX2 = NRTMAX - IRTRAV+1 C ISOMRG = ITRAV C NSOMAX = NBN1 BUG OS16.08.99 : NSOMAX = NBN1*2 IARERG = ISOMRG+NSOMAX NARMAX = NBARET ITRAV = IARERG + 2*NARMAX NITMX2 = NITMAX - ITRAV+1 C NBSORG = 0 NBARRG = 0 CALL RGARET(IDE1,IARETE,NBNMX1,NBN1,NBARET, C > IAR2RG,IREGIO, > IAR2RG,NBRGMX,IREGIO, > ITVL(ISOMRG),NBSORG,NSOMAX, > ITVL(IARERG),NBARRG,NARMAX, > ITVL(ITRAV),NITMX2,RTVL(IRTRAV),NRTMX2,ITRACE,IERR) IF(IERR.NE.0)THEN CALL DSERRE(1,IERR,' RGRAFT','APPEL A RGARET') GOTO 9999 ENDIF C ==================================== C --- ETAPE 1. EXTRACTION D'UN MAILLAGE --- C ==================================== C C --- RENUMEROTATION DES NOEUDS DE LA REGION C INEWNU = ITRAV ITRAV = INEWNU + NBN1 NITMX2 = NITMAX - ITRAV IF( NITMX2.LT.0 )THEN IERR = -2 CALL DSERRE(1,IERR,' RGRAFT','ENTIERS POUR INEWNU') GOTO 9999 ENDIF DO 5 I=1,NBSORG OLDNUM = ITVL(I-1+ISOMRG) ITVL((OLDNUM-1)+INEWNU) = I 5 CONTINUE C C --- EXTRACTION ET COPIE DES COORDONNEES DES NOEUDS DE LA REGION C ICOOM = IRTRAV C IRTRAV = NBSORG*IDIMC + ICOOM IRTRAV = NBPMAX*IDIMC + ICOOM NRTMX2 = NRTMAX - IRTRAV IF( NRTMX2.LT.0 )THEN IERR = -2 CALL DSERRE(1,IERR,' RGRAFT','REELS POUR ICOOM') GOTO 9999 ENDIF DO 20 I=1,NBSORG OLDNUM = ITVL(I-1+ISOMRG) NEWNUM = ITVL((OLDNUM-1)+INEWNU) DO 10 J=1,IDIMC RTVL((NEWNUM-1)*IDIMC+ICOOM-1+J) = COORD((OLDNUM-1)*IDIMC+J) 10 CONTINUE 20 CONTINUE C C --- EXTRACTION ET COPIE DES TS DES NOEUDS DE LA REGION C IF( MODDEF.EQ.3 )THEN NRADEC = NBSORG NBTSN = 1 C PRINT *,'CONCENTRATION NODALE NRIDEC,NFADEC = ',NRIDEC,NFADEC IRADEC = IRTRAV IRTRAV = IRADEC + NBPMAX*NBTSN NRTMX2 = NRTMAX - IRTRAV+1 IF( NITMX2.LT.0 )THEN IERR = -2 CALL DSERRE(1,IERR,' RGRAFT','ENTIERS POUR IRADEC') GOTO 9999 ENDIF DO 52 I=1,NBSORG OLDNUM = ITVL(I-1+ISOMRG) NEWNUM = ITVL((OLDNUM-1)+INEWNU) DO 51 J=1,NBTSN RTVL((NEWNUM-1)*NBTSN+IRADEC-1+J) = > RADEC((OLDNUM-1)*NBTSN+J) 51 CONTINUE 52 CONTINUE ENDIF C C --- EXTRACTION ET COPIE DES GRANDEURS DES NOEUDS DE LA REGION C IGRDMX = -1 IF( NGRDMX.NE.0 )THEN NBGRD = 1 C PRINT *,' GRANDEURS DES NOEUDS NGRDMX= ',NGRDMX IGRDMX = IRTRAV IRTRAV = IGRDMX + NBPMAX*NBGRD NRTMX2 = NRTMAX - IRTRAV+1 IF( NITMX2.LT.0 )THEN IERR = -2 CALL DSERRE(1,IERR,' RGRAFT','ENTIERS POUR IGRDMX') GOTO 9999 ENDIF DO 54 I=1,NBSORG OLDNUM = ITVL(I-1+ISOMRG) NEWNUM = ITVL((OLDNUM-1)+INEWNU) DO 53 J=1,NBGRD RTVL((NEWNUM-1)*NBGRD+IGRDMX-1+J) = > GRDNOE((OLDNUM-1)*NBGRD+J) 53 CONTINUE 54 CONTINUE ENDIF C C --- EXTRACTION ET COPIE DES ARETES DE LA REGION C IARMA = ITRAV ITRAV = IARMA + 2*NBARRG NITMX2 = NITMAX - ITRAV IF( NITMX2.LT.0 )THEN IERR = -2 CALL DSERRE(1,IERR,' RGRAFT','ENTIERS POUR IARMA') GOTO 9999 ENDIF DO 60 I=1,NBARRG OLDNUM = ITVL((I-1)*NBNMX1+IARERG) NEWNUM = ITVL((OLDNUM-1)+INEWNU) ITVL((I-1)*2+IARMA) = NEWNUM OLDNUM = ITVL((I-1)*NBNMX1+IARERG+1) NEWNUM = ITVL((OLDNUM-1)+INEWNU) ITVL((I-1)*2+IARMA+1)= NEWNUM 60 CONTINUE C =========================================== C --- ETAPE 2 : CALCUL DU MAILLAGE DE LA REGION --- C =========================================== C C --- ALLOCATION : CALCUL DE NBPMX2, NBEMX2 NBETR = 2*NBARRG PSTRUC = 1 PITRRG = 0 TSN = 0 ICOEF = 0 C ON PREND LA PLACE QUE L'ON A NBPTOT = -1 C CALL DS4MAX(IDIMC,NMT,NBN,NBE,NBPTOT, CALL DS4MAX(IDIMC,1,NBSORG,NBETR,NBPTOT, > PSTRUC,PITRRG,TSN,ICOEF,IDIMG,NITMX2, > NRTMX2,NBPMX2,NBEMX2,IERR) IF(IERR.NE.0)THEN CALL DSERRE(1,IERR,' RGRAFT','1 APPEL A DS4MAX') GOTO 9999 ENDIF C ON NE DOIT PAS DEPASSER NBPMAX !!! IF( NBPMX2.GT.NBPMAX )THEN CALL DS4MAX(IDIMC,1,NBSORG,NBETR,NBPMAX, > PSTRUC,PITRRG,TSN,ICOEF,IDIMG,NITMX2, > NRTMX2,NBPMX2,NBEMX2,IERR) IF(IERR.NE.0)THEN CALL DSERRE(1,IERR,' RGRAFT','2 APPEL A DS4MAX') GOTO 9999 ENDIF ENDIF C IF(ITRACE.GT.1 )THEN CALL ESEINT(1,'NOMBRE MAXIMUM DE NOEUDS : ',NBPMX2,1) CALL ESEINT(1,'NOMBRE MAXIMUM D ELEMENTS : ',NBEMX2,1) ENDIF C NBNMX3 = 3 NBCMX3 = 3 IRGNOE = ITRAV IRGTRI = NBNMX3*NBEMX2 + IRGNOE IRGNOT = NBCMX3*NBEMX2 + IRGTRI NOEMX2 = NBPMX2 ITRAV = NOEMX2 + IRGNOT C MODIF O.STAB 05.03.2001 : BUG ajout ligne suivante NITMX2 = NITMAX - ITRAV NBNRG = 0 NBERG = 0 NCCRG = 0 IF( MODDEF.EQ.3 )THEN C CALL DSTRAF(IDE1,IARETE,NBNMX1,NBN1,NBARET, CALL DSTRAF(IDE1,ITVL(IARMA),2,NBSORG,NBARRG, C > IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,NOEMAX, > IDE,ITVL(IRGNOE),NBNMX3,ITVL(IRGTRI),NBCMX3, > ITVL(IRGNOT),NOEMX2, > NBNRG,NBERG,NCCRG,NBPMX2,NBEMX2, > RTVL(ICOOM),IDIMC, C > GRDNOE,NGRDMX, > RTVL(IGRDMX),NGRDMX, > MODDEF,MODGEN,NBPNEW, C > IADEC,NIADEC,RADEC,NRIDEC,NFADEC, > IADEC,NIADEC,RTVL(IRADEC),NRADEC,NFADEC, > ITVL(ITRAV),NITMX2,RTVL(IRTRAV),NRTMX2,ITRACE,IERR) ELSE CALL DSTRAF(IDE1,ITVL(IARMA),2,NBSORG,NBARRG, C > IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,NOEMAX, > IDE,ITVL(IRGNOE),NBNMX3,ITVL(IRGTRI),NBCMX3, > ITVL(IRGNOT),NOEMX2, > NBNRG,NBERG,NCCRG,NBPMX2,NBEMX2, > RTVL(ICOOM),IDIMC, C > GRDNOE,NGRDMX, > RTVL(IGRDMX),NGRDMX, > MODDEF,MODGEN,NBPNEW, > IADEC,NIADEC,RADEC,NRIDEC,NFADEC, C > IADEC,NIADEC,RTVL(IRADEC),NRADEC,NFADEC, > ITVL(ITRAV),NITMX2,RTVL(IRTRAV),NRTMX2,ITRACE,IERR) ENDIF C IF(IERR.LT.0)THEN CALL DSERRE(1,IERR,' RGRAFT','APPEL A DSTRAF') GOTO 9999 ENDIF C ---- LIMITATION DONNE PAR L'UTILISATEUR --- C IERR = 2 : NOMBRE MAXIMUM D ELEMENTS ATTEINT: C IERR = 1 : NOMBRE MAXIMUM DE NOEUDS ATTEINT: C IERR = 0 : TAILLE SOUHAITEE ATTEINTE (FRONTIERE): C PRINT *,'APRES DSRAF : INODE = ',IERR INODE = IERR IERR = 0 C ======================================================== C --- ETAPE 3 : INSERTION DU RESULTAT DANS LE MAILLAGE GLOBAL --- C ======================================================== C C --- ON ATTRIBUT DES NUMEROS AUX NOUVEAUX NOEUDS : C NBSORG A NBNRG --> NBN A NBN+(NBNRG-NBSORG) C NEWNOD = ITRAV ITRAV = NEWNOD + (NBNRG-NBSORG) NITMX2 = NITMAX - ITRAV IF( NITMX2.LT.0 )THEN IERR = -2 CALL DSERRE(1,IERR,' RGRAFT','POUR LES NOUVEAUX NOEUDS') GOTO 9999 ENDIF C ATTENTION NBN PEUT ETRE PLUS GRAND QUE NBSORG=FRT DU DOMAINE DO 70 I=1,(NBNRG-NBSORG) NBN = NBN + 1 ITVL(NEWNOD+I-1)= NBN 70 CONTINUE C C --- ON EMPILE LES COORDONNEES DES NOUVEAUX NOEUDS C IF( NBPMAX.LT.NBN )THEN IERR = -2 CALL DSERRE(1,IERR,' RGRAFT','COORD POUR LES NOUVEAUX NOEUDS') GOTO 9999 ENDIF DO 90 I=1,(NBNRG-NBSORG) NUMNOD = ITVL(NEWNOD+I-1) DO 80 J=1,IDIMC COORD((NUMNOD-1)*IDIMC+J)=RTVL((I+NBSORG-1)*IDIMC+ICOOM+J-1) 80 CONTINUE 90 CONTINUE C C --- ON EMPILE LES GRANDEURS DES NOUVEAUX NOEUDS C IF( NGRDMX.NE.0 )THEN IF( NGRDMX.LT.NBN )THEN IERR = -2 CALL DSERRE(1,IERR,' RGRAFT','GRDNOE POUR LES NOUVEAUX NOEUDS') GOTO 9999 ENDIF DO 91 I=1,(NBNRG-NBSORG) NUMNOD = ITVL(NEWNOD+I-1) DO 81 J=1,NBGRD GRDNOE((NUMNOD-1)*NBGRD+J)=RTVL((I+NBSORG-1)*NBGRD+IGRDMX+J-1) 81 CONTINUE 91 CONTINUE ENDIF C C --- ON EMPILE LES TS AUX NOUVEAUX NOEUDS C IF( MODDEF.EQ.3 )THEN NBTSN = 1 NBTSMX = NBPMAX C SI TOUT EST BIEN FAIT ! IF( NBTSMX.LT.NBN )THEN IERR = -2 CALL DSERRE(1,IERR,' RGRAFT','RADEC POUR LES NOUVEAUX NOEUDS') GOTO 9999 ENDIF DO 92 I=1,(NBNRG-NBSORG) NUMNOD = ITVL(NEWNOD+I-1) DO 82 J=1,NBTSN RADEC((NUMNOD-1)*NBTSN+J)=RTVL((I+NBSORG-1)*NBTSN+IRADEC+J-1) 82 CONTINUE 92 CONTINUE ENDIF C C --- ON EMPILE LES ELEMENTS AVEC LES ANCIENS NUMEROS DE NOEUDS --- C DO 110 I=1,NBERG DO 100 J=1,NBNMAX NEWNUM = ITVL((I-1)*3+IRGNOE-1+J) IF( NEWNUM.GT.NBSORG )THEN ITRNOE((I+NBE-1)*NBNMAX+J)= ITVL((NEWNUM-NBSORG-1)+NEWNOD) ELSE ITRNOE((I+NBE-1)*NBNMAX+J)= ITVL((NEWNUM-1)+ISOMRG) ENDIF 100 CONTINUE 110 CONTINUE NBE = NBE + NBERG C IERR = INODE C 9999 END C ********************************************************************** C FICHIER : API_RAFFINE.F C OBJET : GENERATION ET INSERTION DES POINTS SUR UNE TRIANGULATION C C FONCT. : C OBJET DSRAFT : RAFFINE UNE TRIANGULATION plane ET TAILLE SOUHAITE AUX NOEUDS C OBJET GNRAFT : RAFFINE UNE TRIANGULATION (surface 3D) MULTI-REGIONS C C AUTEUR : O. STAB C DATE : 10.10.98 C TESTS : C MODIFICATIONS : C AUTEUR, DATE, OBJET : O.STAB, 27.07.99, EXTRACTION DE DS4_NOEUD2D.F C ET SUPPRESSION DES E/S. C O.STAB, 19.06.2001, GNRAFT (ERREUR ET MESSAGE) C POUR LE MULTI-MAT EN 3D. C O.STAB, 02.02.2005, DSRAFT limitation des noeuds C ********************************************************************** C C SUBROUTINE DSRAFT(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,NOEMAX, > NBN,NBE,NCC,NBPMAX,NBEMAX, > COORD,IDIMC, > GRDNOE,NGRDMX, > MODDEF,MODGEN,NBPNEW, > IADEC,NIADEC,RADEC,NRIDEC,NFADEC, > ITVL,NITMAX,RTVL,NRTMAX,ITRACE,IERR) C ********************************************************************** C OBJET DSRAFT : RAFFINE UNE TRIANGULATION plane ET TAILLE SOUHAITE AUX NOEUDS C APPEL RFRAFF PUIS DNCCTB C C EN ENTREE : C --- le maillage (avec la structure de donnees) mais pas de region --- C IDE,ITRNOE,NBNMX,ITRTRI,NBCMAX,NOETRI,NBE : la triangulation existante C COORD,IDIMC,NBN : coordonnee des points C --- donnees aux noeuds --- C GRDNOE,NGRDMX : grandeurs aux noeuds C --- la densite --- C MODDEF,MODGEN,NBPNEW : C IADEC,NIADEC,RADEC,NRIDEC,NFADEC : C C EN SORTIE : C ---- LIMITATIONS DONNEES PAR L'UTILISATEUR --- C IERR = 2 : NOMBRE MAXIMUM D ELEMENTS ATTEINT: C IERR = 1 : NOMBRE MAXIMUM DE NOEUDS ATTEINT: C IERR = 0 : TAILLE SOUHAITEE ATTEINTE (FRONTIERE): ' C C REMARQUE : IDEM DS1FCT (AUX SIGNATURES DE RFRAFF PRES) C ATTENTION CONTRAIREMENT A DS1FCT LES REGIONS NE SONT PAS MAINTENUS ! C ATTENTION NBPNEW n'est pas correctement gere : seul le cas = 0 est traite !!! C ********************************************************************** INTEGER IDE,ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX,NOETRI(*),NOEMAX INTEGER NBN,NBE,NCC,NBPMAX,NBEMAX REAL COORD(*),GRDNOE(*) INTEGER IDIMC,NGRDMX INTEGER ITVL(*) REAL RTVL(*),RADEC(*) INTEGER MODDEF,MODGEN,NBPNEW,IADEC(*),NFADEC,NIADEC,NRIDEC INTEGER NITMAX,NRTMAX,ITRACE,IERR C INTEGER NCCMAX,IERTSA,NBPMX2 EXTERNAL D2ISUI,DNCHPO C IERTSA = 0 IF( NBPNEW.EQ.0)GOTO 500 C --- ajout 02.02.2005 NBPMX2 = MIN(NBPMAX,NBPNEW+NBN) GOTO( 100,200,300 ) MODDEF IERR = -1 CALL DSERRE(1,IERR,'DSRAFT','DEFINITION DENSITE INCORRECTE') GOTO 9999 C ======================== C --- RAFFINEMENT PAR DEFAUT --- C ======================== 100 CONTINUE CALL RFRAFF(MODDEF, C > MODGEN, > ITRNOE,NBNMAX,ITRTRI,NBCMAX, > NOETRI,NOEMAX, C > ITRIRG,NRGMAX, > COORD,IDIMC,NBN,NBE,NBPMX2,NBEMAX, > 0,IADEC,NIADEC,RADEC,NRIDEC,NFADEC, > ITVL,NITMAX,RTVL,NRTMAX, > IERR) IF(IERR.LT.0)THEN CALL DSERRE(1,IERR,'DSRAFT',' APPEL RFRAFF') GOTO 9999 ENDIF GOTO 400 C =========================================== C --- CONCENTRATIONS(X,Y) OU VALEURS NODALES --- C =========================================== 200 CONTINUE CALL RFRAFF(MODDEF, C > MODGEN, > ITRNOE,NBNMAX,ITRTRI,NBCMAX, > NOETRI,NOEMAX, C > ITRIRG,NRGMAX, > COORD,IDIMC,NBN,NBE,NBPMX2,NBEMAX, > D2ISUI,IADEC,NIADEC,RADEC,NRIDEC,NFADEC, > ITVL,NITMAX,RTVL,NRTMAX, > IERR) IF(IERR.LT.0)THEN CALL DSERRE(1,IERR,'DSRAFT',' APPEL RFRAFF (D2ISUI)') GOTO 9999 ENDIF GOTO 400 C =========================================== C --- VALEURS NODALES --- C =========================================== 300 CONTINUE CALL RFRAFF(MODDEF, C > MODGEN, > ITRNOE,NBNMAX,ITRTRI,NBCMAX, > NOETRI,NOEMAX, C > ITRIRG,NRGMAX, > COORD,IDIMC,NBN,NBE,NBPMX2,NBEMAX, > DNCHPO,IADEC,NIADEC,RADEC,NRIDEC,NFADEC, > ITVL,NITMAX,RTVL,NRTMAX, > IERR) IF(IERR.LT.0)THEN CALL DSERRE(1,IERR,'DSRAFT',' APPEL RFRAFF (DNCHPO)') GOTO 9999 ENDIF GOTO 400 C 400 CONTINUE C TAILLE SOUHAITE ATTEINTE ? (0), NOMBRE MAX ELEMENT (2), NOEUD (1) IERTSA = IERR IERR = 0 C C ================================================ C --- CALCUL DES TAILLES SOUHAITEES AU NOEUDS --- C ================================================ 500 CONTINUE IERR = 0 IF( NGRDMX.LE.0 )GOTO 8000 IF( NGRDMX.LT.NBN )THEN IERR = -2 CALL DSERRE(1,IERR,'DSRAFT','PLUS DE PLACE ') GOTO 9999 ENDIF C GOTO( 600,700,800 ) MODDEF C --- RAF PAR DEFAUT 600 CONTINUE CALL DNCCTB(MODDEF,IDE,ITRNOE,NBNMAX,NBE, > ITRTRI,NBCMAX, > 0,IADEC,NIADEC,RADEC,NRIDEC,NFADEC, > COORD,IDIMC,NBN,GRDNOE,IERR) GOTO 1000 C --- CONCENTRATION (X,Y) 700 CONTINUE CALL DNCCTB(MODDEF,IDE,ITRNOE,NBNMAX,NBE, > ITRTRI,NBCMAX, > D2ISUI,IADEC,NIADEC,RADEC,NRIDEC,NFADEC, > COORD,IDIMC,NBN,GRDNOE,IERR) GOTO 1000 C --- VALEURS NODALES 800 CONTINUE CALL DNCCTB(MODDEF,IDE,ITRNOE,NBNMAX,NBE, > ITRTRI,NBCMAX, > DNCHPO,IADEC,NIADEC,RADEC,NRIDEC,NFADEC, > COORD,IDIMC,NBN,GRDNOE,IERR) GOTO 1000 C 1000 CONTINUE IF( IERR.NE.0 )THEN CALL DSERRE(1,IERR,'DSRAFT','APPEL DNCCTB ') GOTO 9999 ENDIF C --- FIN --- 8000 CONTINUE IERR = IERTSA C 9999 END C C SUBROUTINE GNRAFT(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,NOEMAX, > NBN,NBE,NCC,NBPMAX,NBEMAX, > COORD,IDIMC, C --- AJOUT POUR LES MATERIAUX : > ITRIRG,NRGMAX,IMTREF,NMT,INTMAT,NMTCC, > GRDNOE,NGRDMX, > MODDEF,MODGEN,NBPNEW, > IADEC,NIADEC,RADEC,NRIDEC,NFADEC, > ITVL,NITMAX,RTVL,NRTMAX,ITRACE,IERR) C ********************************************************************** C OBJET GNRAFT : RAFFINE UNE TRIANGULATION (2D,3D) MULTI-REGIONS C creation de la structure de donnees ITRTRI,NOETRI C APPEL DSRAFT C EN ENTREE : C ---- la triangulation initiale --- C IDE,ITRNOE,NBNMX,NBCMAX,NBE : la triangulation existante C COORD,IDIMC,NBN : coordonnee des points C ITRIRG,NRGMAX,IMTREF,NMT,INTMAT,NMTCC : les regions C --- la densite --- C MODDEF,MODGEN,NBPNEW : C IADEC,NIADEC,RADEC,NRIDEC,NFADEC : C C EN SORTIE : C --- la triangulation mise a jour et la structure de donnees --- C C REMARQUE : C APPEL DSRAFT C ********************************************************************** INTEGER IDE,ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX,NOETRI(*),NOEMAX INTEGER NBN,NBE,NCC,NBPMAX,NBEMAX REAL COORD(*),GRDNOE(*) INTEGER IDIMC,NGRDMX INTEGER ITRIRG(*),NRGMAX,IMTREF(*),NMT,INTMAT(*),NMTCC INTEGER ITVL(*) REAL RTVL(*),RADEC(*) INTEGER MODDEF,MODGEN,NBPNEW,IADEC(*),NFADEC,NIADEC,NRIDEC INTEGER NITMAX,NRTMAX,ITRACE,IERR C ---- MODIF POUR LA PROJECTION --- INTEGER IDIMC2,ICOO2D,IORIG,IMATT,IND1,IND2,IPOINT(1),NPOINT INTEGER I,J C INTEGER ITRAV,NITMX2,IRTRAV,NRTMX2 INTEGER IUN,NMT2 INTEGER NDECMX INTEGER IFR,NBNIFR,NBIFR,IMATFR,NFRMAX,IDE1,NMT1,MAJNOE INTEGER INODE,NBN2 INTEGER INTMAX,IMTMAX C IUN = 1 ITRAV = 1 NITMX2 = NITMAX IRTRAV = 1 NRTMX2 = NRTMAX C ===================================================== C --- 1. CREATION DE LA STRUCTURE DE DONNEES --- C ===================================================== CALL SMAOCR(IDE,ITRNOE,NBE,COORD,NBN,IDIMC, > ITRNOE,NBNMAX,ITRTRI, > NBCMAX,NOETRI,NOEMAX, > ITVL(ITRAV),NITMX2,NCC,IERR) IF( IERR.NE.0 )THEN CALL DSERRE(1,IERR,'GNRAFT',' APPEL SMAOCR') GOTO 9999 ENDIF C IF( ITRACE.NE.0 ) C > CALL ESEINT(1,'NOMBRE DE COMPOSANTES CONNEXES : ',NCC,1) C ===================================================== C --- 2. EXTRACTION DES REGIONS C ON EXTRAIT LES ARETES DE LA FRONTIERE ( ITVL(IFR)) C ET LES REGIONS INCIDENTS ( ITVL(IMATFR) ) C ===================================================== C --- CAS MONO-REGION -- NBIFR = 0 IMATFR = ITRAV ITRAV = ITRAV + 1 C ITVL(IMATFR) = IMTREF(1) NMTCC = 1 C IF( NMT.GT. 1 )THEN C --- ATTENTION NE FONCTIONNE QUE POUR LE 2D : IF( IDE.EQ.3 )THEN IERR = -3 CALL DSERRE(1,IERR,'GNRAFT',' PAS IMPLEMENTE EN 3D!') GOTO 9999 ENDIF C --- CAS POLY-REGION --- C IF(ITRACE.GT.0) C > CALL ESECHA(1,'-> SAUVEGARDE DES REGIONS',' ') C CALL TBIT2V(INTMAT,IMTREF,NMT,ITRIRG, > NBE,IERR) IF( IERR.NE.0 )THEN CALL DSERRE(1,IERR,'GNRAFT',' APPEL TBIT2V') GOTO 9999 ENDIF C NBNIFR = 2 CALL RGNORG(IDE,ITRNOE,NBNMAX,ITRTRI, > NBCMAX,NBE,ITRIRG,NMT,0,NBIFR, > 0,NBNIFR,0,0,IERR) IF( IERR.NE.-2 )THEN CALL DSERRE(1,IERR,'GNRAFT',' APPEL RGNORG') GOTO 9999 ENDIF C PRINT *,'ON A :',NBIFR,' ARETES DE FRONTIERE' C IERR = 0 NFRMAX = NBIFR IFR = ITRAV IMATFR = (NBNIFR * NFRMAX) + IFR ITRAV = IMATFR + (2*NBIFR) NITMX2 = NITMAX - ITRAV C CALL RGNORG(IDE,ITRNOE,NBNMAX,ITRTRI, > NBCMAX,NBE,ITRIRG,NMT,ITVL(IFR),NBIFR, > NFRMAX,NBNIFR,ITVL(IMATFR),NFRMAX,IERR) C IF( IERR.NE.0 )THEN CALL DSERRE(1,IERR,'GNRAFT',' APPEL RGNORG') GOTO 9999 ENDIF C IF( ITRACE.NE.0 ) C > CALL ESEINT(1,'NOMBRE D ARETES DE FRONTIERE : ',NBIFR,1) C C --- IL FAUT LIBERER ITRIRG EN COMPRIMANT IFR ET IMATFR --- C --- INSERTION DES FRONTIERES INTERIEURES --- C C AJOUT ITVL,NITMX2 : 26.01.99 DO 10 I=1,NBIFR CALL SFRICR(ITVL((I-1)*NBNIFR+IFR),2,IDE, > ITRNOE,NBNMAX,ITRTRI,NBCMAX, > NOETRI,NBE,ITVL(ITRAV),NITMX2,IERR) IF( IERR.NE. 0 )THEN CALL DSERRE(1,IERR,'GNRAFT',' APPEL SFRICR') GOTO 9999 ENDIF 10 CONTINUE ENDIF C --- POUR LE DEBUG --- C =============== C CALL SDBTRI(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI, C > NBE,NBN,ITRACE,IERR) C IF( IERR.NE. 0 )THEN C CALL DSERRE(1,IERR,'GNRAFT',' APPEL SDBTRI 1') C GOTO 9999 C ENDIF C C ======================================== C --- 3. GENERATION DES NOEUDS DANS LE PLAN ET C INSERTION DANS LA TRIANGULATION --- C ======================================== C 50 CONTINUE C C ITBDEN = IRTRAV C NDENMX = NBPMAX C IRTRAV = ITBDEN + NDENMX C NRTMX2 = NRTMAX - IRTRAV + 1 INODE = 0 C IF( IDIMC.EQ.3 )THEN IF((IDIMC.EQ.3 ).AND.(IDE.EQ.2))THEN C ---- PROJECTION SUR LE PLAN DES MOINDRES CARRES SI 3D --- IDIMC2 = 2 IF(IDIMC.EQ.3 )THEN ICOO2D = IRTRAV IORIG = ICOO2D + NBPMAX*IDIMC2 IMATT = IORIG + 3 IRTRAV = IMATT + 9 C NRTMX2 = NITMAX - IRTRAV , BUG 080699: NRTMX2 = NRTMAX - IRTRAV IND1 = 1 IND2 = NBN IPOINT(1) = 0 NPOINT = 0 CALL RPPNCR(IPOINT,NPOINT,IND1,IND2, > COORD,IDIMC, > ITVL(ITRAV),NITMX2,RTVL(IRTRAV),NRTMX2, > RTVL(IORIG),RTVL(IMATT),RTVL(ICOO2D),IDIMC2,IERR) C ---- POUR LE DEBUG ---- C ORIG : NOUVELLE ORIGINE C IMATT : MATRICE 3x3 DE PASSAGE DANS LE NOUVEAU REPERE C PRINT *,'GNRAFT: ORIG = ',RTVL(IORIG),RTVL(IORIG+1),RTVL(IORIG+2) C DO 60 I=1,MIN(NBN,10) C PRINT *,(RTVL((I-1)*IDIMC2+ICOO2D+J-1),J=1,IDIMC2) C 60 CONTINUE IF( IERR.NE.0 )THEN CALL DSERRE(1,IERR,'GNRAFT','APPEL RPPNCR') GOTO 9999 ENDIF C --- ATTENTION NE RIEN LIBERER CA SERT PLUS LOIN !!! C IRTRAV = IORIG C NRTMX2 = NRTMAX - IRTRAV ENDIF C NBN2 = NBN CALL DSRAFT(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX, > NOETRI,NOEMAX, > NBN2,NBE,NCC,NBPMAX,NBEMAX, C > ITRIRG,NRGMAX,IMTREF,NMT, > RTVL(ICOO2D),IDIMC2, > GRDNOE,NGRDMX, C > RTVL(ITBDEN),NDENMX, > MODDEF,MODGEN,NBPNEW, > IADEC,NIADEC,RADEC,NRIDEC,NFADEC, > ITVL(ITRAV),NITMX2,RTVL(IRTRAV),NRTMX2,ITRACE,INODE) C --- INTERPOLATION DES POINTS CALCULES 2D -> 3D C YMAT(3,3) = RTVL(IMAT) C CALL M33INV(YMATT,XMATT,IERR) CALL M33INV(RTVL(IMATT),RTVL(IMATT),IERR) IF( IERR.NE. 0 )THEN CALL DSERRE(1,IERR,'GNRAFT','APPEL M33INV') GOTO 9999 ENDIF C C PRINT *,'ON PROJETE LES POINTS GENERES ',NBN2-NBN DO 70 I=(NBN+1),NBN2 C --- LES POINTS GENERES SERONT SUR LE PLAN MOYEN COORD((I-1)*IDIMC+1) = RTVL((I-1)*IDIMC2+ICOO2D) COORD((I-1)*IDIMC+2) = RTVL((I-1)*IDIMC2+ICOO2D+1) COORD((I-1)*IDIMC+3) = 0.0 C CALL SOMMVE(COORD((I-1)*IDIMC+1),RTVL(IORIG),IDIMC, C > COORD((I-1)*IDIMC+1)) CALL M33APP(RTVL(IMATT),COORD((I-1)*IDIMC+1),IDIMC,IUN, > RTVL(IRTRAV),COORD((I-1)*IDIMC+1)) CALL SOMMVE(COORD((I-1)*IDIMC+1),RTVL(IORIG),IDIMC, > COORD((I-1)*IDIMC+1)) 70 CONTINUE NBN = NBN2 C ELSE CALL DSRAFT(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX, > NOETRI,NOEMAX, > NBN,NBE,NCC,NBPMAX,NBEMAX, C > ITRIRG,NRGMAX,IMTREF,NMT, > COORD,IDIMC, > GRDNOE,NGRDMX, C > RTVL(ITBDEN),NDENMX, > MODDEF,MODGEN,NBPNEW, > IADEC,NIADEC,RADEC,NRIDEC,NFADEC, > ITVL(ITRAV),NITMX2,RTVL(IRTRAV),NRTMX2,ITRACE,INODE) ENDIF C IF(IERR.LT.0)THEN CALL DSERRE(1,IERR,'GNRAFT',' APPEL DSRAFT') GOTO 9999 ENDIF C --- POUR LE DEBUG --- C =============== C CALL SDBTRI(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI, C > NBE,NBN,ITRACE,IERR) C IF( IERR.NE. 0 )THEN C CALL DSERRE(1,IERR,'GNRAFT',' APPEL SDBTRI 2') C GOTO 9999 C ENDIF C C ================================== C --- 3.2. AFFECTATION DES REGIONS --- C ================================== C INTMAT(1) = NBE IF( NMT.GT.1 )THEN C IF(ITRACE.GT.0) C > CALL ESECHA(1,'-> HERITAGE DES REGIONS',' ET RENUMEROTATION') C NBNIFR = 2 C --- C'EST UN NOUVEAU ITRIRG !!! IDE1 = IDE - 1 NMT1 = NMT MAJNOE = 0 IMTMAX = NMT INTMAX = NMT CALL DFR2RG(IDE1,ITVL(IFR),NBNIFR,NBIFR,ITVL(IMATFR),NMT1, > IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX, > NOETRI,NOEMAX,NBE, > MAJNOE, > ITRIRG,NRGMAX,IMTREF,IMTMAX, > INTMAT,INTMAX,NMTCC, > ITVL(ITRAV),NITMX2,IERR) C IF( IERR .NE. 0 )THEN CALL DSERRE(1,IERR,'GNRAFT','APPEL DFR2RG') GO TO 9999 ENDIF ENDIF C IF((ITRACE.GT. 0 ).AND.(NMTCC.GT.1))THEN C CALL ESEINT(1, C > 'NOMBRE DE REGIONS : ',NMTCC,1) C CALL ESEINT(1, C > 'REFERENCE DES REGIONS : ',IMTREF,NMTCC) C CALL ESEINT(1, C > 'NUMEROS DES ELEMENTS : ',INTMAT,NMTCC) C ENDIF C IERR = INODE C 9999 END C C ***************************************************************** C MODULE : M6 (EXTRACTION D'UN MAILLAGE 2D) C FICHIER : M6_REQUETE.F C OBJET : REQUETES SUR UN MAILLAGE POUR LES ELEMENTS FINIS C C LA SYNTAXE D'UNE REQUETE : C (NOMBRE DE NOEUDS,N1...NM,REF,+/-REGION) C C LE RESULTAT D'UNE REQUETE EST MIS DANS UN ENSEMBLE C DE LA FORME : REF, TYPE, ELEMENTS = { (E,I) } C AVEC (E,I) : E = ELEMENT, C I = ADRESSE RELATIVE DE L'ENTITE DANS C L'ELEMENT C FONCT. : C C --- 3 REQUETES ELEMENTAIRES --- C C RQ2AR : L'ENSEMBLE DES ARETES DE LA FRONTIERE C DE LA REGION DONNEE ENTRE N1 ET N2 C C RQELNO : L'ENSEMBLE DES ELEMENTS DE LA REGION DONNEE C S'APPUYANT SUR LE NOEUD DONNE C C RQELRG : LES ELEMENTS DE LA REGION DONNEE (MAT) C C AUTEUR : O. STAB C DATE : 02.96 C TESTS : C MODIFICATIONS : C AUTEUR, DATE, OBJET : O.STAB, 17.08.98, AJOUT RQ2ENS C O.STAB, 09.03.05, modif REQ2D, type ensemble cree = -1 C C C ***************************************************************** C C SUBROUTINE RQ2GAR(N1,N2,MATG, > ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI, > IMAT, > IELEMS,NBELE,NELMAX,IERR) C ***************************************************** C OBJET RQ2GAR : FRONTIERE ENTRE 2 NOEUDS DE LA FRONTIERE C D'UN MATERIAU (2D) C EN ENTREE: C N1,N2 : LES 2 NOEUDS (SUR LA FRONTIERE DE MAT) C MATG : REFERENCE DU MATERIAU C A GAUCHE DE LA FRONTIERE SI POSITIF C OU A DROITE SI NEGATIF C ITRNOE,...NOETRI,IMAT : LE MAILLAGE C IELEMS : TABLEAU RESULTAT (FRONTIERE) C NELMAX : NOMBRE MAXIMUM D'ELEMENTS FRONTIERE = C TAILLE DU TABLEAU / 2 C NNOE : TABLEAU RESULTAT (LISTE DES NOEUDS) C NBNNOEMAX : NOMBRE MAXIMUM DE NOEUD = TAILLE DU TABLEAU C C EN SORTIE : C IELEMS : FRONTIERE TRIEE DE N1 VERS N2 (DOUBLET = (E,A)) C E = ELEMENT DE MATERIAU "MATG" C A = NUMERO RELATIF DE L'ARETE DE E C NBELE : NOMBRE D'ELEMENT DE LA FRONTIERE C IERR : -1 SI N1 ET N2 NE SONT PAS SUR LA FRONTIERE DE MAT C REMARQUES : C - LA FRONTIERE D'UN MEME MATERIAU DOIT ETRE REGULIERE C EN TOUT NOEUD DE LA FRONTIERE DE MAT IL N'Y A QUE 2 C ARETES INCIDENTES C ****************************************************** INTEGER N1,N2,MATG INTEGER ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX,NOETRI(*),IMAT(*) INTEGER IELEMS(*), NBELE,NELMAX INTEGER IERR C INTEGER NI,ITD,IT,IT2,IARD,IAR,IAR2 INTEGER IDE,ISENS,ISOM,NBNE,IARS EXTERNAL STRNBN INTEGER STRNBN C IERR = -1 NBELE = 0 IF(( N1.LE. 0 ).OR.( N2.LE. 0 ))GOTO 999 C ISENS = 1 IDE = 2 NI = N1 NBNE = NBCMAX C C --- ON TOURNE AUTOUR DE N1 DANS LE SENS DIRECT --- C DES QUE L'ON TROUVE MATG ON S'ARRETE C C === BOUCLE SUR LES NOEUDS === C 5 CALL SESFR2(NI,ISENS,IDE,ITRNOE,NBNMAX,ITRTRI, > NBCMAX,NOETRI,IT,IAR) C --- ERREUR : N1 EST ISOLE --- IF( IT.EQ. 0 )GOTO 999 ITD = IT IARD = IAR C C === BOUCLE SUR LES ARETES D'UN NOEUD === C 10 IF( NBNMAX.NE.3 )NBNE = STRNBN(IT,ITRNOE,NBNMAX) IARS = MOD(IAR,NBNE)+1 CALL SESFR1(IT,IARS,ITRTRI,NBCMAX,IT2,IAR2) C C --- LE MATERIAU EST A GAUCHE --- C IF((IMAT(IT).EQ.MATG).AND. > ((IT2.EQ.0).OR.(IMAT(IT2).NE.MATG)))GOTO 20 C C --- ERREUR : ON A PAS TROUVE "MATG" SUR N1 --- IF(( IT2.EQ.ITD ).AND.( IAR2.EQ.IARD ))GOTO 999 IF( IT2.EQ. 0 )GOTO 999 C --- ON PASSE AU SUIVANT --- IT = IT2 IAR = IAR2 GOTO 10 C C ---- ON A TROUVE UNE ARETE --- C 20 NBELE = NBELE+1 IF( NBELE.LE.NELMAX )THEN IELEMS((NBELE-1)*2+1) = IT IELEMS((NBELE-1)*2+2) = IARS ENDIF ISOM = MOD(IARS,NBNE)+1 NI = ITRNOE((IT-1)*NBNMAX+ISOM) IF( NI.EQ.N2 )GOTO 30 IF( NI.EQ.N1) GOTO 999 GOTO 5 C C --- ON A TROUVE N2 --- C 30 IERR = 0 C IF((NELMAX.GT.0).AND.(NELMAX.LT.NBELE))IERR=-2 C 999 END C C SUBROUTINE RQ2AR(N1,N2,MAT, > ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,IMAT, > IELEMS,NBELE,NELMAX,IERR) C ***************************************************** C OBJET RQ2AR : REQUETE SUR LA FRONTIERE DES MAILLES D'ATTRIBUT C DONNE C EN ENTREE: C ------------ LOCALISATION -------------- C N1,N2 : LES 2 NOEUDS (SUR LA FRONTIERE DE MAT) C MATG : REFERENCE DU MATERIAU C A GAUCHE DE LA FRONTIERE SI POSITIF C OU A DROITE SI NEGATIF C C ------------ MAILLAGE ----------------- C ITRNOE,...NOETRI,IMAT : LE MAILLAGE C C ------------ L'ENSEMBLE ---------------- C IDENS : DIMENSION DES ELEMENTS DE L'ENSEMBLE C IELEMS : TABLEAU DES ELEMENTS DE L'ENSEMBLE C NELMAX : NOMBRE MAXIMUM D'ELEMENTS DANS IELEMS C C EN SORTIE : C IELEMS : TABLEAU DES ELEMENTS DE L'ENSEMBLE C NBELE : NOMBRE D'ELEMENTS DANS IELEMS C IERR : -1 C -2 C -3 C REMARQUES : C - LA FRONTIERE D'UN MEME MATERIAU DOIT ETRE REGULIERE C EN TOUT NOEUD DE LA FRONTIERE DE MAT IL N'Y A QUE 2 C ARETES INCIDENTES C ****************************************************** INTEGER N1,N2,MAT INTEGER ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX,NOETRI(*) INTEGER IMAT(*) INTEGER IELEMS(*),NBELE,NELMAX,IERR C INTEGER ITAMPO,I C IERR = 0 IF( MAT.LT. 0) THEN C C --- "MATERIAU" A DROITE --- C ===================== CALL RQ2GAR(N2,N1,-MAT, > ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,IMAT, > IELEMS,NBELE,NELMAX,IERR) IF( IERR.NE.0 )GOTO 999 C --- PERMUTATION : ATTENTION C'EST DES DOUBLETS --- DO 10 I=1,(NBELE/2) ITAMPO = IELEMS((I-1)*2+1) IELEMS((I-1)*2+1) = IELEMS((NBELE-I)*2+1) IELEMS((NBELE-I)*2+1) = ITAMPO ITAMPO = IELEMS((I-1)*2+2) IELEMS((I-1)*2+2) = IELEMS((NBELE-I)*2+2) IELEMS((NBELE-I)*2+2) = ITAMPO 10 CONTINUE C C --- "MATERIAU" A GAUCHE --- C ===================== ELSE CALL RQ2GAR(N1,N2,MAT, > ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,IMAT, > IELEMS,NBELE,NELMAX,IERR) IF( IERR.NE.0 )GOTO 999 ENDIF C 999 END C C C SUBROUTINE RQELNO(N1,MAT, > ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,IMAT, > IELEMS,NBELE,NELMAX,IERR) C ***************************************************** C OBJET RQELNO : REQUETE SUR LES NOEUDS C C EN ENTREE: C N1 : LE NOEUD RECHERCHE C MAT : VALEUR DU MATERIAU DES ELEMENTS RECHERCHES C C ------------ MAILLAGE ----------------- C IDE : DIMENSION DU MAILLAGE C ITRNOE,...NOETRI,IMAT : LE MAILLAGE C C ------------ L'ENSEMBLE ---------------- C IELEMS : TABLEAU DES ELEMENTS DE L'ENSEMBLE C NELMAX : NOMBRE MAXIMUM D'ELEMENTS DANS IELEMS C C EN SORTIE : C IELEMS : TABLEAU DE DOUBLETS (E,N) C C NBELE : NOMBRE D'ELEMENTS DANS IELEMS C IERR : -1 C -2 C -3 C REMARQUES : C - LA FRONTIERE D'UN MEME MATERIAU DOIT ETRE REGULIERE C EN TOUT NOEUD DE LA FRONTIERE DE MAT IL N'Y A QUE 2 C ARETES INCIDENTES C ****************************************************** INTEGER N1,MAT INTEGER ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX,NOETRI(*) INTEGER IMAT(*) INTEGER IELEMS(*),NBELE,NELMAX,IERR C INTEGER ISENS,IT,ITD,IAR,IARS,J,NBNE,IDE EXTERNAL STRNBN INTEGER STRNBN C ISENS = 1 NBELE = 0 IERR = 0 IDE = 2 C C --- ON TOURNE AUTOUR DE N1 DANS LE SENS DIRECT --- C DES QUE L'ON TROUVE MAT ON S'ARRETE C 5 CALL SESFR2(N1,ISENS,IDE,ITRNOE,NBNMAX,ITRTRI, > NBCMAX,NOETRI,IT,IAR) C --- ERREUR : N1 EST ISOLE --- IF( IT.EQ. 0 )GOTO 999 ITD = IT C =================================== C --- BOUCLE SUR LES ARETES DU NOEUD N1 --- C =================================== 10 IF((MAT.EQ.0).OR.(IMAT(IT).EQ.MAT))THEN C C --- ON AJOUTE UN ELEMENT A L'ENSEMBLE --- C NBELE = NBELE + 1 IF( NBELE.GE.NELMAX )THEN IERR = -2 GOTO 999 ENDIF IELEMS((NBELE-1)*2+1) = IT C --- IL FAUT RETROUVER LE NOEUD N1 --- DO 20 J=1,NBNMAX IF( ITRNOE((IT-1)*NBNMAX+J).EQ.N1 ) > IELEMS((NBELE-1)*2+2) = J 20 CONTINUE ENDIF C C --- ON PASSE AU SUIVANT --- C NBNE = 3 IF( NBNMAX.NE.3 )NBNE = STRNBN(IT,ITRNOE,NBNMAX) IARS = MOD(IAR,NBNE)+1 CALL SESFR1(IT,IARS,ITRTRI,NBCMAX,IT,IAR) C C --- ERREUR : ON A PAS TROUVE "MAT" SUR N1 --- IF(( IT.EQ.ITD ).OR.( IT.EQ. 0 ))GOTO 999 GOTO 10 C 999 END C C C SUBROUTINE RQELRG(MAT,IMAT,NBE, > IELEMS,NBELE,NELMAX,IERR) C ***************************************************** C OBJET RQELRG : REQUETES SUR LES ELEMENTS D'UN MAILLAGE D'UN C MATERIAU DONNE C EN ENTREE : C MAT : LE MATERIAU SOUHAITE C IMAT : TABLEAU DES MATERIAUX DES ELEMENTS C IMAT(I) = MATERIAU DE L'ELEMENT I C NBE : NOMBRE D'ELEMENT DU MAILLAGE C C IELEMS : TABLEAU A REMPLIR C NELMAX : NOMBRE MAXIMUM DE DOUBLET DANS IELEMS C C EN SORTIE : C IELEMS : TABLEAU DE DOUBLET (E,0) DES ELEMENTS DE C MATERIAU DONNE : IMAT(E) = MAT C NBELE : NOMBRE DE DOUBLETS C IERR : -2, IELEMS TROP PETIT C ***************************************************** INTEGER MAT,IMAT(*),NBE INTEGER IELEMS(*),NBELE,NELMAX,IERR C INTEGER J C NBELE = 0 DO 10 J=1,NBE IF( IMAT(J).EQ.MAT )THEN NBELE = NBELE + 1 IF( NBELE.GE.NELMAX )THEN IERR =-2 GOTO 999 ENDIF IELEMS((NBELE-1)*2+1) = J IELEMS((NBELE-1)*2+2) = 0 ENDIF 10 CONTINUE 999 END C SUBROUTINE REQ2D(NOEREQ,MAXRQ,IRGRQ,IRFRQ,NBREQ, > IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,NBE,IMAT, > ITVL, > IELEMS,MAXELE,IENS,ITYEN,IRFENS,NBENS,IERR ) C ***************************************************** C OBJET REQ2D : REQUETES SUR UN MAILLAGE 2D. C SYNTAXE : (NOEUD...) (+/- MAT) REF C C EN ENTREE: C ---- LES REQUETES ---- C NOEREQ : NOEUDS DE CHAQUE REQUETES C MAXRQ : NOMBRE MAXIMUM DE NOEUDS PAR REQUETE C IRGRQ : MATERIAU ASSOCIE A LA REQUETE C IRFRQ : REFERENCE DE L'ENSEMBLE ASSOCIE A LA C REQUETE C NBREQ : NOMBRE DE REQUETES C ---- LE MAILLAGE ---- C ITRNOE,...NOETRI,IMAT : LE MAILLAGE C C ITVL : TABLEAU DE TRAVAIL DE "NBREQ" ENTIERS C C EN SORTIE : C IENS : ADRESSE DES ENSEMBLES (DANS IELEMS) C ADRESSE DU DERNIER ELEMENT DE CHAQUE ENSEMBLE C TAILLE DE IENS <= NBREQ. C ITYEN : TYPE DES ENSEMBLES (FRONTIERE OU ELEMENT) C IRFENS : REFERENCE (OU NUMERO) DE L'ENSEMBLE C (C'EST LA REFERENCE DE LA REQUETE). C NBENS : <= NBREQ (LE RESULTAT DE PLUSIEURS REQUETES C PEUT ETRE MIS DANS UN MEME ENSEMBLE) C C IELEMS : TABLEAU DES ELEMENTS DES ENSEMBLES C MAXELE: TAILLE MAXIMUM DE IELEMS (EN ENTREE) C C IERR : -1 SI UNE REQUETE EST INCORRECTE C -2 SI IELEMS EST TROP PETIT C REMARQUES : C - LA FRONTIERE D'UN MEME MATERIAU DOIT ETRE REGULIERE C EN TOUT NOEUD DE LA FRONTIERE DE MAT IL N'Y A QUE 2 C ARETES INCIDENTES C C - LES REQUETES SONT TRAITEES DANS L'ORDRE DES REFERENCES C CROISSANTES. C ****************************************************** INTEGER NOEREQ(*),MAXRQ,IRGRQ(*),IRFRQ(*),NBREQ INTEGER IDE,ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX INTEGER NOETRI(*),NBE,IMAT(*),ITVL(*) INTEGER IELEMS(*), MAXELE INTEGER IENS(*),ITYEN(*),IRFENS(*), NBENS, IERR C INTEGER IRFENP,IIENS,I,J,NB,II,NOE(4),ITYPE INTEGER NBELE,NELMAX INTEGER IORDRE C IERR = -3 IF( IDE.NE.2 )GOTO 999 IERR = -1 IF( MAXRQ.GT.2 )GOTO 999 C ============================================= C --- 1. TRIER LES REQUETES SUIVANT L'ORDRE DES --- C REFERENCES CROISSANTES C ============================================= IORDRE = 1 CALL KNUTP(NBREQ,ITVL(IORDRE),IRFRQ) C ========================== C --- 2. REALISER LES REQUETES --- C ========================== IRFENP = 0 NBENS = 0 IIENS = 0 DO 200 I=1,NBREQ C ------------------------------ C --- 2.1 DEFINITION DE L'ENSEMBLE --- C ------------------------------ II = ITVL(IORDRE+I-1) C --- CREATION D'UN ENSEMBLE --- C ------------------------ IF( IRFRQ(II).NE.IRFENP )THEN NBENS = NBENS + 1 IRFENS(NBENS) = IRFRQ(II) C ITYEN(NBENS) = 0 ITYEN(NBENS) = -1 IRFENP = IRFRQ(II) ENDIF C --- TYPE DE L'ENSEMBLE --- C -------------------- NB = MAXRQ DO 100 J=MAXRQ,1,-1 NOE(J) =NOEREQ((II-1)*MAXRQ+J) IF( NOE(J).EQ.0 ) NB = (J-1) 100 CONTINUE IERR = -1 GOTO( 110,120,130,140 ) (NB+1) CALL DSERRE(1,IERR,'REQ2D',' REQUETE INCONNUE') GOTO 999 C --- RECHERCHE DES MAILLES (2D/3D)--- 110 CONTINUE ITYPE = IDE GOTO 150 C --- RECHERCHE DES NOEUDS 120 CONTINUE ITYPE = 0 GOTO 150 C --- RECHERCHE DES ARETES --- 130 CONTINUE IF( IDE.LT.2 )THEN CALL DSERRE(1,IERR,'REQ2D',' NBR NOEUD > ELEMENTS') GOTO 999 ENDIF ITYPE = 1 GOTO 150 C --- RECHERCHE DES FACES --- 140 CONTINUE IF(IDE.LT.3)THEN CALL DSERRE(1,IERR,'REQ2D',' NBR NOEUD > ELEMENTS') GOTO 999 ENDIF ITYPE = 2 GOTO 150 C 150 CONTINUE C --- ON VERIFIE LES TYPES DES REQUETES --- C ----------------------------------- C IF(ITYEN(NBENS).NE.0)THEN C creation : -1 (modif 09.03.2005) IF(ITYEN(NBENS).NE.-1)THEN IF(ITYEN(NBENS).NE.ITYPE)THEN CALL DSERRE(1,IERR,'REQ2D',' MELANGE DE TYPE INTERDIT') GOTO 999 ENDIF ELSE ITYEN(NBENS) = ITYPE ENDIF IERR = 0 C IIENS DONNE LE NOMBRE D'ELEMENT DANS IELEMS NELMAX = ( MAXELE - IIENS ) / 2 NBELE = 0 C ----------------------- C --- 2.2 REQUETE SOMMET --- C ----------------------- IF( ITYPE.EQ.0 )THEN CALL RQELNO(NOE(1),IRGRQ(II), > ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,IMAT, > IELEMS((2*IIENS)+1),NBELE,NELMAX,IERR) ELSE C ----------------------- C --- 2.3 REQUETE ARETE --- C ----------------------- IF( IDE.GT.ITYPE )THEN CALL RQ2AR(NOE(1),NOE(2),IRGRQ(II), > ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,IMAT, > IELEMS((2*IIENS)+1),NBELE,NELMAX,IERR) C ELSE C --------------------- C --- 2.4 REQUETE ELEMENT --- C --------------------- IF( IDE.EQ.ITYPE )THEN CALL RQELRG(IRGRQ(II),IMAT,NBE, > IELEMS((2*IIENS)+1),NBELE,NELMAX,IERR) ELSE IERR = -1 ENDIF ENDIF ENDIF IF( IERR.NE. 0 )THEN CALL DSERRE(1,IERR,'REQ2D',' APPEL REQUETES ELEMENTAIRES') GOTO 999 ENDIF IIENS = IIENS + NBELE IENS(NBENS) = IIENS 200 CONTINUE C 999 END C C SUBROUTINE RQ2ENS(IDE,ITRNOE,NBNMAX,NBE,NBN,INTMAT,IREGIO,NMT, > NOEREQ,NBMXRQ,IMATRQ,IREFRQ,NBREQ, > IELENS,NBMXEL,IENS,ITYPEN,IREFEN,NBENS, > ITVL,NITMAX,RTVL,NRTMAX,IERR) C ********************************************************************** C OBJET RQ2ENS : REQUETES SUR UN MAILLAGE 2D C C EN ENTREE : C ------------- LE MAILLAGE ------------------ C IDE,ITRNOE,NBNMAX,NBE,NBE,INTMAT,IREGIO,NMT C C ------------- LES REQUETES ----------------- C NOEREQ,NBMXRQ,IMATRQ,IREFRQ,NBREQ C C ---- TABLEAUX DE TRAVAIL -------------------- C ITVL : TABLEAU D'ENTIERS POUR LES CALCULS C NITMAX : TAILLE DE ITVL C NBE*NBCMAX -> ITRTRI C + NBN -> NOETRI C + NBE -> IMAT C + [NBREQ,2*NBN] -> POUR ITRAV C -------------- C (NBCMAX+1)*NBE + NBN*3 -> TOTAL MINIMUM CONSEILLE C C EN SORTIE : C --- DES ENSEMBLES --------------------------- C IELENS,NBMXEL,IENS,ITYPEN,IREFEN,NBENS C IERR : CODE D'ERREUR C 0 OK C -1 SI DONNEES INCORRECTES C -2 SI TABLEAUX INSUFFISANTS C ITVL TROP PETIT C RTVL TROP PETIT) C TROP DE MATERIAUX (>50) C ********************************************************************** INTEGER IDE,ITRNOE(*),NBNMAX,NBE,NBN,INTMAT(*),IREGIO(*),NMT INTEGER NOEREQ(*),NBMXRQ,IMATRQ(*),IREFRQ(*),NBREQ INTEGER IELENS(*),NBMXEL,IENS(*),ITYPEN(*),IREFEN(*),NBENS INTEGER ITVL(*),NITMAX,NRTMAX,IERR REAL RTVL(*) C --- VARIABLES INTERNES --- INTEGER ITRTRI,NOETRI,ITRAV,NBCMAX,IDIMC,ICOORD INTEGER NITMX2,I,NCC,NBNOMX INTEGER IMAT C C ========================================= C --- 2. CREATION DE LA STRUCTURE DE DONNEES --- C ========================================= C C ======================= C --- 2.1. ALLOCATION --- C ======================= C NBCMAX = NBNMAX C ICOORD = 1 ITRTRI = 1 NOETRI = ITRTRI + (NBE * NBCMAX) ITRAV = NOETRI + NBN NITMX2 = NITMAX - ITRAV NBNOMX = NBN C IF(NITMX2.LT.0)THEN IERR = -2 CALL DSERRE(1,IERR,'RQ2ENS', > ' TABLEAUX DE TRAVAIL TROP PETITS') GOTO 999 ENDIF C CALL SMAOCR(IDE,ITRNOE,NBE,RTVL(ICOORD), > NBN,IDIMC, > ITRNOE,NBNMAX,ITVL(ITRTRI), > NBCMAX,ITVL(NOETRI),NBNOMX, > ITVL(ITRAV),NITMX2,NCC,IERR) IF( IERR.NE.0 )THEN CALL DSERRE(1,IERR,'RQ2ENS',' APPEL SMAOCR') GOTO 999 ENDIF C ======================= C --- TABLEAU DES MATERIAUX --- C ======================= IMAT = NOETRI + NBN CALL TBIT2V(INTMAT,IREGIO,NMT,ITVL(IMAT),NBE,IERR) IF( IERR.NE.0 )THEN CALL DSERRE(1,IERR,'RQ2ENS',' APPEL TBIT2V') GOTO 999 ENDIF C C ============================ C --- 3. REQUETES SUR LE MAILLAGE --- C ============================ C --- REQUETES --- C ----------------------- ITRAV = IMAT + NBE CALL REQ2D(NOEREQ,NBMXRQ,IMATRQ,IREFRQ,NBREQ, > IDE,ITRNOE,NBNMAX, > ITVL(ITRTRI),NBCMAX,ITVL(NOETRI),NBE, > ITVL(IMAT), > ITVL(ITRAV), > IELENS,NBMXEL,IENS,ITYPEN,IREFEN,NBENS,IERR ) C IF( IERR.NE.0 )THEN CALL DSERRE(1,IERR,'RQ2ENS',' APPEL REQ2D') GOTO 999 ENDIF C 999 END C C ********************************************************************** C MODULE : C FICHIER : 3D_UNDEF.F C OBJET : DECLARATION DES APPELS AU 3D C FONCT. : C C AUTEUR : O. STAB C DATE : C TESTS : C MODIFICATIONS : C AUTEUR, DATE, OBJET : C C C ********************************************************************** SUBROUTINE SFRI3D_NEW(NN,NBNN, > IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX, > NOETRI,NBE,ITVL,NITMAX, > IT1,IT2,I1,I2,IERR) C ************************************************************* C OBJET SFRI3D : ELEMENTS SUR LA FACE NN (VOIR SFRIDE) C C EN ENTREE: C NN : TABLEAU DES SOMMETS DE L'ELEMENT FRONTIERE C NBNN : NOMBRE DE SOMMETS C IDE : DIMENSION DES ELEMENTS DU MAILLAGE C NBE : NOMBRE D'ELEMENTS DU MAILLAGE C C EN SORTIE: C IT1 : L'ELEMENT QUI CONTIENT LA FACE NN(1),NN(2),NN(3) C I1 : L'INDICE DE LA FACE DANS IT1 C IT2 : L'ELEMENT QUI CONTIENT LA FACE NN(3),NN(2),NN(1) C I2 : L'INDICE DE LA FACE DANS IT1 C REMARQUE : 3D SEULEMENT C NE PREND PAS EN COMPTE LES FRONTIERES INTERNES C ************************************************************* INTEGER NN(*),NBNN,IDE,ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX INTEGER NOETRI(*),NBE,ITVL(*),NITMAX INTEGER IT1,IT2,I1,I2,IERR C IERR = -3 9999 END C FUNCTION TTVO_AJETER(P1,P2,P3,P4) C ***************************************************************** C ***************************************************************** REAL TTVO REAL P1(*),P2(*),P3(*),P4(*) C TTVO = 0. 9999 END C SUBROUTINE TTAJPO(IPT,ITD,ITRNOE,NBNMAX,NBEMAX,ITRTRI,NBCMAX, > NOETRI,NBE,COORD,SPH,NBSMAX, > ITVL,IMAX,SZERO,DFRMIN,MODERR,NBTNEW,IERR) C ********************************************************************** C ********************************************************************** INTEGER IPT,ITD,NBSMAX,NBTNEW INTEGER ITRNOE(*),NBNMAX,NBEMAX,ITRTRI(*),NBCMAX INTEGER NOETRI(*),NBE,ITVL(*),IMAX,MODERR REAL SPH(*),COORD(*),SZERO,DFRMIN INTEGER IERR C IERR = -3 9999 END C SUBROUTINE SPSPHE(IDIMC,I,ITRI,COORD,SPHERE,ZERO,IERR) C ********************************************************************** C ********************************************************************** INTEGER ITRI(4),IDIMC,I,IERR REAL COORD(*),SPHERE(4),ZERO C IERR = -3 9999 END C C SUBROUTINE STTTEV(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,NOEMAX, > COORD,IDIMC,NBN,NBE, > ITVL,IMAX,RTVL,IRMAX,IERR) C ***************************************************************** C ********************************************************************** INTEGER IDE,NBE,ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX INTEGER ITVL(*),IMAX,IDIMC,NOETRI(*),NOEMAX,NBN,IRMAX,IERR REAL COORD(*),RTVL(*) C IERR = -3 9999 END C ********************************************************************** C MODULE : C FICHIER : SP_SPH.F C OBJET : GESTION DES SPHERES CIRCONSCRITES (CAS 2D ET 3D) C FONCT. : C OBJET SPCREE : CREER LA SPHERE CIRCONSCRITE AU SIMPLEXE C C AUTEUR : O. STAB C DATE : 03.95 C MODIFICATIONS : C AUTEUR, DATE, OBJET : O.STAB, 13.11.97, RESTRUCTURATION C C C ********************************************************************** C SUBROUTINE SPCREE(IDIMC,ISPH,ITRI,COORD,SPH,ZERO,IERR) C ********************************************************************** C OBJET SPCREE : CREER LA SPHERE CIRCONSCRITE AU SIMPLEXE C EN ENTREE : C IDIMC : DIMENSION DE L'ESPACE C ISPH : NUMERO DU TRIANGLE C ITRI : LES SOMMETS DU TRIANGLE C COORD: TABLEAU DES COORDONNEES DES POINTS C SPH : TABLEAU DES SPHERES C ZERO : C EN SORTIE: C SPH : TABLEAU DES SPHERES AUQUEL A ETE AJOUTE CELLE CREEE C IERR : CODE D'ERREUR -1 SI LE TRIANGLE EST PLAT C C ********************************************************************** INTEGER IDIMC INTEGER ITRI(*),ISPH,IERR REAL COORD(*),SPH(*),ZERO C C INTEGER SPCIRC C EXTERNAL SPCIRC C IF( IDIMC .EQ. 2 )THEN C IERR = SPCIRC(ITRI,COORD,SPH((ISPH-1)*3+1),ZERO) CALL SPCERC(IDIMC,ISPH,ITRI,COORD,SPH((ISPH-1)*3+1),ZERO,IERR) ELSE IF( IDIMC .EQ. 3 )THEN CALL SPSPHE(IDIMC,ISPH,ITRI,COORD,SPH((ISPH-1)*4+1),ZERO,IERR) ELSE IERR = -1 ENDIF ENDIF END C C ********************************************************************** C MODULE : (RAFFINEMENT D'UN MAILLAGE TRIANGULAIRE) C FICHIER : D3_DENSDEF.F C OBJET : CALCUL DE LA DENSITE POUR RAFFINER C UNE TRIANGULATION DE DELAUNAY C FONCT. : C OBJET DNARMN : LONGUEUR DE L'ARETE LA PLUS COURTE (ARETE,TRIANGLE,TETRA) C OBJET DNARET : LONGUEUR DE L'ARETE LA PLUS LONGUE (ARETE,TRIANGLE,TETRA) C OBJET DNTSDF : TAILLE SOUHAITE PAR DEFAUT C OBJET DNIDEF : CF DNTSDF - FONCTION PARAMETRE C OBJET DNCHPO : TAILLE SOUHAITE / CONCENTRATION CHAMPS DE POINTS C OBJET DNVERI : VERIFICATION DES DENSITES DONNEES - A TESTER - C OBJET DNCCTB : CALCUL DES DENSITES DONNEES AUX NOEUDS C C AUTEUR : O. STAB C DATE : C TESTS : C MODIFICATIONS : C AUTEUR, DATE, OBJET : C C C ********************************************************************** C C SUBROUTINE DNARMN(IDE,NUMP,COORD,IDIMC,DLONGU) C ***************************************************************** C OBJET DNARMN : LONGUEUR DE L'ARETE LA PLUS COURTE C ***************************************************************** INTEGER IDE,NUMP(*),IDIMC REAL COORD(*) REAL DLONGU C EXTERNAL XNORVE REAL XNORVE REAL V(3),D INTEGER I,II C ---- BUG_34 : O.STAB 17.10.97, COORD ETAIT DECLARE ENTIER ---- C CALL DIFFVE(COORD((NUMP(1)-1)*IDIMC+1), > COORD((NUMP(2)-1)*IDIMC+1),IDIMC,V) DLONGU = XNORVE(V,IDIMC) C --- CAS D'UNE ARETE --- IF( IDE.EQ. 1 )GOTO 9999 DO 20 I=2,3 II = MOD(I,3)+1 CALL DIFFVE(COORD((NUMP(I)-1)*IDIMC+1), > COORD((NUMP(II)-1)*IDIMC+1),IDIMC,V) D = XNORVE(V,IDIMC) DLONGU = MIN( D, DLONGU ) 20 CONTINUE C --- CAS D'UN TRIANGLE --- IF( IDE.EQ.2 )GOTO 9999 C --- CAS D'UN TETRAEDRE --- II = 4 DO 30 I=1,3 CALL DIFFVE(COORD((NUMP(I)-1)*IDIMC+1), > COORD((NUMP(II)-1)*IDIMC+1),IDIMC,V) D = XNORVE(V,IDIMC) DLONGU = MIN( D, DLONGU ) 30 CONTINUE C 9999 END C C SUBROUTINE DNARMX(IDE,NUMP,COORD,IDIMC,DLONGU) C ***************************************************************** C OBJET DNARET : LONGUEUR DE L'ARETE LA PLUS LONGUE C ***************************************************************** INTEGER IDE,NUMP(*),IDIMC REAL COORD(*) REAL DLONGU C EXTERNAL XNORVE REAL XNORVE REAL V(3),D INTEGER I,II C ---- BUG_34 : O.STAB 17.10.97, COORD ETAIT DECLARE ENTIER ---- C CALL DIFFVE(COORD((NUMP(1)-1)*IDIMC+1), > COORD((NUMP(2)-1)*IDIMC+1),IDIMC,V) DLONGU = XNORVE(V,IDIMC) C --- CAS D'UNE ARETE --- IF( IDE.EQ. 1 )GOTO 9999 DO 20 I=2,3 II = MOD(I,3)+1 CALL DIFFVE(COORD((NUMP(I)-1)*IDIMC+1), > COORD((NUMP(II)-1)*IDIMC+1),IDIMC,V) D = XNORVE(V,IDIMC) DLONGU = MAX( D, DLONGU ) 20 CONTINUE C --- CAS D'UN TRIANGLE --- IF( IDE.EQ.2 )GOTO 9999 C --- CAS D'UN TETRAEDRE --- II = 4 DO 30 I=1,3 CALL DIFFVE(COORD((NUMP(I)-1)*IDIMC+1), > COORD((NUMP(II)-1)*IDIMC+1),IDIMC,V) D = XNORVE(V,IDIMC) DLONGU = MAX( D, DLONGU ) 30 CONTINUE C 9999 END C C C SUBROUTINE DNTSDF(NUMP,IDIMC,COORD,VDIA,COEF,TS,IERR) C ***************************************************************** C OBJET DNTSDF : TAILLE SOUHAITE PAR DEFAUT C (LA TAILLE SOUHAITE EST EVALUEE AU CENTRE D'UNE BOULE) C EN ENTREE : C VDIA : LE VECTEUR DIAMETRE PARTANT DE XPC C IDIMC : DIMENSION DE L'ESPACE C EN SORTIE : C TS : TAILLE SOUHAITE POUR LE TRIANGLE C = LONGUEUR DE SA PLUS PETITE ARETE C COEF : TS / RC C RC EST LE RAYON DU CERCLE CIRCONSCRIT C PLUS COEF EST PETIT PLUS ON RAFFINE C IERR : CODE D'ERREUR 0 SI OK, C -1 SI LE RAYON CIRCONSCRIT EST NUL C NIVEAU : FICHIER C ***************************************************************** INTEGER NUMP(*),IDIMC REAL COORD(*) REAL VDIA(*),COEF,TS INTEGER IERR C INTEGER IDE REAL DMIN,DIAM2,RC EXTERNAL XNORVE,SCALVE,NULLVE REAL XNORVE,SCALVE INTEGER NULLVE C IERR = -1 IDE = IDIMC CALL DNARMN(IDE,NUMP,COORD,IDIMC,DMIN) DIAM2 = SCALVE(VDIA,VDIA,IDIMC) RC = SQRT(DIAM2) / 2.0 C PRINT *,'DANS DNIDEF : RC = ',RC IF( NULLVE(RC,1) .NE. 0 )GOTO 9999 COEF = DMIN / RC TS = DMIN C PRINT *,'DANS DNIDEF : COEF = ',COEF C PRINT *,'DANS DNIDEF : TS = ',TS IERR = 0 9999 END C C C SUBROUTINE DNIDEF(IT,ITRNOE,NBNMAX,ITRTRI,NBCMAX, > COORD,IDIMC,SPH,NBSMAX,ITAB,RTAB,COEF,TS,IERR) C **************************************************************** C OBJET DNIDEF : CF DNTSDF - FONCTION PARAMETRE C EN ENTREE : C --------- L'ELEMENT A RAFFINER ------------------- C IT : NUMERO DE L'ELEMENT A RAFFINER C ITRNOE,NBNMAX,ITRTRI,NBCMAX : LE MAILLAGE C COORD,IDIMC : COORDONNEES DANS L'ESPACE DE DIMENSION IDIMC C SPH,NBSMAX : VECTEUR DIAMETRE DES SPHERES CIRCONSCRITES C --------- LE POINT DE CONCENTRATION ------------ C ITAB() , RTAB() : INUTILISES C EN SORTIE : C TS : TAILLE SOUHAITE POUR L'ELEMENT IT C LONGUEUR DE SA PLUS PETITE ARETE C COEF : TS / RC C RC EST LE RAYON DU CERCLE CIRCONSCRIT C PLUS COEF EST PETIT PLUS ON RAFFINE C IERR : CODE D'ERREUR 0 SI OK, C -1 SI LE RAYON CIRCONSCRIT A IT EST NUL C NIVEAU : MODULE C **************************************************************** REAL COORD(*),SPH(*),COEF,TS INTEGER IT,ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX,NBSMAX INTEGER IDIMC,ITAB(*) REAL RTAB(*) INTEGER IERR C CALL DNTSDF(ITRNOE((IT-1)*NBNMAX+1),IDIMC,COORD, > SPH((IT-1)*NBSMAX+1),COEF,TS,IERR) C 9999 END C SUBROUTINE DNCHPO(IT,ITRNOE,NBNMAX,ITRTRI,NBCMAX, > COORD,IDIMC,SPH,NBSMAX,ITAB,RTAB,COEF,TS,IERR) C **************************************************************** C OBJET DNCHPO : TAILLE SOUHAITE A L'ELEMENT / CHAMPS DE VALEURS C FONCTION PARAMETRE C C EN ENTREE : C --------- L'ELEMENT A RAFFINER ------------------- C IT : NUMERO DE L'ELEMENT A RAFFINER C ITRNOE,NBNMAX,ITRTRI,NBCMAX : LE MAILLAGE C ITRTRI,NBCMAX (INUTILISES) C COORD,IDIMC : COORDONNEES DANS L'ESPACE DE DIMENSION IDIMC C SPH,NBSMAX : VECTEUR DIAMETRE DES SPHERES CIRCONSCRITES C RTAB(1) : TAILLE SOUHAITEE AU NOEUD 1 C RTAB(2) : TAILLE SOUHAITEE AU NOEUD 2 C RTAB(3...) : .... C C EN SORTIE : C TS : TAILLE SOUHAITE POUR L'ELEMENT IT C ELLE EST DONNE PAR LA CONCENTRATION (ITAB,RTAB) C COEF : A * TS / RC (RAYON DU CERCLE CIRCONSCRIT A IT) C "A" EST TEL QUE 0 <= COEF <=1 C PLUS COEF EST PETIT PLUS ON RAFFINE C IERR : CODE D'ERREUR 0 SI OK, C -1 SI TAILLE SOUHAITE EST NEGATIVE C OU SI LE RAYON CIRCONSCRIT EST NUL C C NIVEAU : INTERFACE UTILISATEUR C **************************************************************** REAL COORD(*),SPH(*),COEF,TS INTEGER IT,ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX,NBSMAX INTEGER IDIMC,ITAB(*) REAL RTAB(*) INTEGER IERR C REAL DMAX,TSD,TSP,ZERO INTEGER I,J,IMOY,NBNE,IDE EXTERNAL XNORVE REAL XNORVE INTEGER STRNBN EXTERNAL STRNBN PARAMETER (ZERO = 1.E-05) C IMOY = 1 C ---- ATTENTION MARCHE POUR DES SIMPLEXES SEULEMENT --- C NBNE = IDIMC+1 NBNE = STRNBN(IT,ITRNOE,NBNMAX) IDE = NBNE - 1 GOTO(100,200,300,400,500) IMOY C C ---- MOYENNE ARITHMETIQUE ---- C 100 CONTINUE TS = 0.0 DO 110 I=1,NBNE TS = RTAB(ITRNOE((IT-1)*NBNMAX+I)) + TS 110 CONTINUE TS = TS / NBNE GOTO 1000 C C ---- MOYENNE GEOMETRIQUE ---- C 200 CONTINUE TS = 1.0 DO 210 I=1,NBNE C PRINT *,' TS(SOMMET) = ',RTAB(ITRNOE((IT-1)*NBNMAX+I)) TS = RTAB(ITRNOE((IT-1)*NBNMAX+I)) * TS 210 CONTINUE C ---- CALCUL APPROCHE DE LA RACINE NIEME : TSP = TS TS = TS**(1.0/NBNE) C TS = 0.43429 * EXP(LOG(TS)/(NBNE*0.43429)) C PRINT *,'RACINE ',NBNE,' IEME DE ',TSP,' = ',TS C PRINT *,'TSP = TS^3 ',TSP,' = ',(TS*TS*TS) GOTO 1000 C C ---- MOYENNE HARMONIQUE ---- C 300 CONTINUE TS = 1.0 DO 310 I=1,NBNE TS = RTAB(ITRNOE((IT-1)*NBNMAX+I)) * TS 310 CONTINUE TSD = 0.0 DO 330 I=1,NBNE TSP = 1.0 DO 320 J=1,NBNE IF( I.NE.J ) > TSP = RTAB(ITRNOE((IT-1)*NBNMAX+J)) * TSP 320 CONTINUE TSD = TSD + TSP 330 CONTINUE TS = NBNE * TS / TSD GOTO 1000 C C ---- MOYENNE DES CARRES ---- C 400 CONTINUE TS = 0.0 DO 410 I=1,NBNE TS = RTAB(ITRNOE((IT-1)*NBNMAX+I))**2 + TS 410 CONTINUE TS = (TS / NBNE)**0.5 GOTO 1000 C C ---- MOYENNE DES CUBES ---- C 500 CONTINUE TS = 0.0 DO 510 I=1,NBNE TS = RTAB(ITRNOE((IT-1)*NBNMAX+I))**3 + TS 510 CONTINUE TS = (TS / NBNE)**(1.0/3.0) GOTO 1000 C 1000 CONTINUE CALL DNARMX(IDE,ITRNOE((IT-1)*NBNMAX+1),COORD,IDIMC,DMAX) C IF( DMAX.LE.ZERO )THEN IERR = -1 CALL DSERRE(1,IERR,'DNCHPO','ARETE DE LONGUEUR NULLE') GOTO 9999 ENDIF COEF = TS / DMAX IERR = 0 C WRITE (6,*) 'TS = ',TS, C > ' DMAX = ',DMAX,' COEF = ',COEF C 9999 END C SUBROUTINE DNCCTB(IMODE,IDE,ITRNOE,NBNMAX,NBE,ITRTRI,NBCMAX, > FADEC,ITAB,NIADEC,RTAB,IRADEC,NFADEC, > COORD,IDIMC,NBN,RTBDEN,IERR) C ********************************************************************** C OBJET DNCCTB : CALCUL DES DENSITES DONNEES AUX NOEUDS C EN ENTREE : C --------- LE MAILLAGE ------------------- C ITRNOE,NBNMAX,ITRTRI,NBCMAX : LE MAILLAGE C COORD,IDIMC : COORDONNEES DANS L'ESPACE DE DIMENSION IDIMC C ---- DEFINITION DU RAFFINEMENT -------------- C FADEC : C ITAB((I-1)*NIADEC+1) : PARAMETRES ENTIERS DU IEME RAFFINEMENT C NIADEC : NOMBRE MAX. DE PARAMETRES ENTIERS C RTAB((I-1)*NIADEC+1) : PARAMETRES REELS DU IEME RAFFINEMENT C IRADEC : NOMBRE MAX. DE PARAMETRES REELS C NFADEC : NOMBRE DE RAFFINEMENTS C C EN SORTIE : C RTBDEN : TABLEAU DES DENSITES AUX NOEUDS (>= NBN) C IERR : CODE D'ERREUR 0 SI OK, C -1 SI DENSITE LA EST INCORRECTE C C REMARQUE : ON TESTE QUE LA DENSITE AUX POINTS > 0.0 C ********************************************************************** REAL COORD(*) INTEGER IMODE,IDE,ITRNOE(*),NBE,NBN,NBNMAX INTEGER ITRTRI(*),NBCMAX,IDIMC INTEGER ITAB(*),NFADEC,NIADEC,IRADEC REAL RTAB(*),RTBDEN(*) EXTERNAL FADEC INTEGER IERR C REAL ZERO,REAMAX,DLONGU,DISTAN,TS REAL COEF,VDIA(3) INTEGER INO,IEL,I C ZERO = 1.E-05 REAMAX = 1.E+38 C VDIA(1) = ZERO C VDIA(2) = ZERO C VDIA(3) = ZERO C PRINT *,'IMODE = ',IMODE GOTO( 100,200,300,400 ) IMODE C C ---- TS = ARETE LA PLUS PETITE ---- C 100 CONTINUE C ------- PAS DE DEFINITION : LA PLUS PETITE ARETE ! --------- DO 105 INO=1,NBN RTBDEN(INO) = REAMAX 105 CONTINUE DO 110 IEL=1,NBE CALL DNARMN(IDE,ITRNOE((IEL-1)*NBNMAX+1),COORD,IDIMC,DLONGU) IF( DLONGU.LT.ZERO )THEN IERR = -1 CALL DSERRE(1,IERR,'DNCCTB','DENSITE NEGATIVE OU NULLE !') C CALL ESEINT(1,' ELEMENT PLAT = ',IEL,1) GOTO 9999 ENDIF DO 107 I=1,(IDE+1) INO = ITRNOE((IEL-1)*NBNMAX+I) RTBDEN(INO) = MIN(DLONGU,RTBDEN(INO)) 107 CONTINUE 110 CONTINUE GOTO 500 C C ---- CONCENTRATIONS PONCTUELLES ET LINEIQUES ---- C 200 CONTINUE IF(IDE.EQ.3) THEN IERR = -3 CALL DSERRE(1,IERR,'DNCCTB','N EXISTE PAS EN 3D') GOTO 9999 ENDIF DO 220 INO=1,NBN C PRINT *,' CALCUL DE TS POUR LE NOEUD ',INO RTBDEN(INO) = REAMAX DO 210 I=1,NFADEC C UN POINT N'EST PAS UN ELEMENT !!! C BUG C CALL D2SUI(VDIA,VDIA,VDIA, C > COORD((INO-1)*IDIMC+1),VDIA,IDIMC, C > ITAB((I-1)*NIADEC+1),RTAB((I-1)*IRADEC+2), C > RTAB((I-1)*IRADEC+1), C > ITAB((I-1)*NIADEC+2), C > RTAB((I-1)*IRADEC+3),COEF,TS,IERR) CALL DIPOOB(IDIMC,COORD((INO-1)*IDIMC+1), > ITAB((I-1)*NIADEC+2),RTAB((I-1)*IRADEC+3), > DISTAN,IERR) C > ITYPO,ROBJET,DBARYC,IERR) CALL SCSUPO(ITAB((I-1)*NIADEC+1),RTAB((I-1)*IRADEC+2), > RTAB((I-1)*IRADEC+1),DISTAN,TS) C CALL SCSUPO(ITYPS,TSP,RSG,DBARYC,TSBARY) C PRINT *,' POUR DENSITE ',I,' LA DENSITE = ',TS IF( IERR.NE. 0 )THEN C CALL DSERRE(1,IERR,'DNCCTB','APPEL D2SUI') CALL DSERRE(1,IERR,'DNCCTB','APPEL DIPOOB') CALL DSERRE(1,IERR,'DNCCTB','APPEL D2SUI') CALL DSERRE(1,IERR,'DNCCTB','CALCUL DE LA DENSITE !') C CALL ESEINT(1,' DENSITE = ',I,1) C CALL ESEINT(1,' AU NOEUD = ',INO,1) ENDIF RTBDEN(INO) = MIN(TS,RTBDEN(INO)) 210 CONTINUE 220 CONTINUE GOTO 500 C ---- CONCENTRATION NODALES ---- 300 CONTINUE DO 310 INO=1,NBN RTBDEN(INO) = RTAB(INO) IF( RTAB(INO).LT.ZERO )THEN IERR = -1 CALL DSERRE(1,IERR,'DNCCTB','DENSITE NEGATIVE OU NULLE !') C CALL ESEINT(1,' DENSITE DU NOEUD = ',INO,1) GOTO 9999 ENDIF 310 CONTINUE GOTO 500 C ---- CONCENTRATION ALEATOIRE ---- 400 CONTINUE IERR = -3 CALL DSERRE(1,IERR,'DNCCTB','DENSITE ALEATOIRE') GOTO 9999 GOTO 500 C ---- ---- 500 CONTINUE DO 510 INO=1,NBN IF( RTBDEN(INO).LT.ZERO )THEN IERR = -1 CALL DSERRE(1,IERR,'DNCCTB','DENSITE NEGATIVE OU NULLE !') C CALL ESEINT(1,' DENSITE AU NOEUD = ',INO,1) GOTO 9999 ENDIF 510 CONTINUE C IERR = 0 9999 END C C ********************************************************************** C MODULE : C FICHIER : rf_raf3d.f C OBJET : RAFFINEMENT D'UNE TRIANGULATION DE DELAUNAY 2D et 3D C FONCT. : C RFRAFF : RAFFINE UN MAILLAGE TRIANGULAIRE 2D et 3D C C FONCT. LOCALES : C OBJET SUGMOY : CALCULE LA VALEUR QUI MINIMISE (pas teste) C OBJET SUTSNO : CALCULE LA VALEUR EN UN NOEUD POUR MINIMISER (LOCAL) C OBJET SXNOVO : RENVOI LES NOEUDS VOISINS D'UN NOEUD(SIMPLEXE) (LOCAL) C OBJET RFNOTS : RENVOI LA TS AU NOEUD A PARTIR DES TS DES KPPV (LOCAL) C OBJET RFRECH : RECHERCHE DE L'ELEMENT A RAFINER (LOCAL) C OBJET RFITER : RAFFINE ITERATIVEMENT UN MAILLAGE TRIANGULAIRE (LOCAL) C C AUTEUR : O. STAB C DATE : C TESTS : C MODIFICATIONS : C AUTEUR, DATE, OBJET : 31.01.05 fusion avec tampo.f (RFNOTS... ) C C C ********************************************************************** C SUBROUTINE SUGMOY(DISTV,VALV,NBV,VALNO) C ***************************************************************** C OBJET SUGMOY : CALCULE LA VALEUR QUI MINIMISE (pas teste) C LA PROGRESSION GEOMETRIQUES DES VALEURS DES KPPV (CONNECTE) C pas testee !! C ***************************************************************** REAL DISTV(*),VALV(*) INTEGER NBV REAL VALNO C REAL SOMNUM,SOMDEN INTEGER I C SOMNUM = 0 SOMDEN = 0 DO 50 I=1,NBV SOMNUM = SOMNUM + (VALV(I)/DISTV(I)) SOMDEN = SOMDEN + (1.0/DISTV(I)) 50 CONTINUE VALNO = SOMNUM / SOMDEN END C C SUBROUTINE SUTSNO(INODE,ITVOIS,NBVOIS,COORD,IDIMC,TVALVO,NBVAL, > VALNO,IERR) C ***************************************************************** C OBJET SUTSNO : CALCULE LA VALEUR EN UN NOEUD POUR MINIMISER (LOCAL) C LA PROGRESSION GEOMETRIQUES DES VALEURS DES KPPV (CONNECTE) C C EN ENTREE : C INODE : LE NOEUD DONT ON CHERCHE LA VALEUR (VALNO) C ITVOIS,NBVOIS : TABLEAU DES NOEUDS VOISINS C COORD,IDIMC : TABLEAU DES COORDONNEES C TVALVO,NBVAL: TABLEAU DES GRANDEURS C C EN SORTIE : C VALNO : LA VALEUR AU NOEUD (INODE) C C REMARQUE : DANS LE CAS D'UN POINT CONFONDU AVEC INODE, CE DERNIER C PREND LA VALEUR (INFLUENCE INFINIE) C ***************************************************************** INTEGER INODE,ITVOIS(*),NBVOIS,IDIMC,NBVAL REAL COORD(*),TVALVO(*) REAL VALNO INTEGER IERR C REAL DISTV,SOMNUM,SOMDEN INTEGER IVOIS,I EXTERNAL DISPP REAL DISPP C COMMON /CGEPSI/XYZHUG,XYZMIN,XYZEPS REAL XYZHUG,XYZMIN,XYZEPS C IF(NBVOIS.LE.0)THEN IERR = -1 GOTO 9999 ENDIF IERR = 0 SOMNUM = 0 SOMDEN = 0 DO 50 I=1,NBVOIS IVOIS = ITVOIS(I) DISTV = DISPP(IDIMC,COORD((INODE-1)*IDIMC+1), > COORD((IVOIS-1)*IDIMC+1)) IF(DISTV.LE.XYZEPS)THEN VALNO = TVALVO(IVOIS) GOTO 9999 ELSE DISTV = 1.0 / DISTV ENDIF SOMNUM = SOMNUM + (TVALVO(IVOIS) * DISTV) SOMDEN = SOMDEN + DISTV 50 CONTINUE VALNO = SOMNUM / SOMDEN 9999 CONTINUE END C C SUBROUTINE SXNOVO(INOEUD,NBTEL,ITRNOE,NBNMAX,ITRTRI,NBCMAX, > ITVL,NITMAX, > ITVOIS,NBVMAX,NBVOIS,IERR) C ***************************************************************** C OBJET SXNOVO : RENVOI LES NOEUDS VOISINS D'UN NOEUD(SIMPLEXE) (LOCAL) C C EN ENTREE : C INOEUD : LE NOEUD DONT ON RECHERCHE LES VOISINS C NBTEL : LES ELEMENTS INCIDENTS A INOEUD C ITRNOE,NBNMAX,ITRTRI,NBCMAX : LE MAILLAGE C ITVL,NITMAX: TABLEAUX DE TRAVAIL C C NBVMAX : TAILLE DU TABLEAU ITVOIS C NBVMAX DOIT ETRE >= 2* NBVOIS C SI NBVMAX < 0 : DANS NBVOIS ON RENVOI LA TAILLE NECESSAIRE A NBVMAX C SI NBVMAX = 0 : DANS NBVOIS ON RENVOI LE NOMBRE DE VOISINS C SI NBVMAX > 0 ET NBVOIS <= NBVMAX : LE TABLEAU ITVOIS EST REMPLI C ET NBVOIS > NBVMAX : ERREUR DE MEMEOIRE (IERR = -2) C C EN SORTIE : C ITVOIS : LE TABLEAU DES NOEUD VOISINS (SI NBVMAX > NBVOIS) C NBVOIS : LE NOMBRE DE NOEUDS VOISINS (SI NBVMAX >= 0) C LA TAILLE NECESSAIRE A ITVOIS (C.A.D NBVMAX) SI NBVMAX <0 C C LIMITATIONS : C 1.FONCTIONNE SUR LES SIMPLEXES C 2.LES ELEMENTS INCIDENTS SONT LES NBTNEW PREMIERS (DU MAILLAGE) C A FAIRE : LEVER LA LIMITATION 2 C ***************************************************************** INTEGER INOEUD,NBTEL INTEGER ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX INTEGER ITVL(*),NITMAX INTEGER ITVOIS(*),NBVMAX,NBVOIS,IERR C INTEGER IVOIS,NBV,ITRAV,I,J C ------------------------------------ C ---- LES ELEMENTS CONTENANT LE NOEUD ----- C ------------------------------------ * pour generaliser la procedure il faudra lever la limitation : elements consecutifs ! C ------------------------------------ C ---- EXTRACTION DES NOEUDS VOISINS ----- C ------------------------------------ * pour tester la memoire : ITVL(NITMAX-1) = 0 * IERR = 0 IVOIS = 1 NBV = 0 DO 30 I=1,NBTEL DO 10 J=1,NBNMAX * on prend tous les noeuds sauf INOEUD (simplexes) IF(ITRNOE((I-1)*NBNMAX+J).NE.INOEUD)THEN NBV = NBV + 1 IF( NBV.GT.NITMAX )THEN IERR = -2 GOTO 9999 ELSE ITVL(IVOIS + NBV - 1)= ITRNOE((I-1)*NBNMAX+J) ENDIF ENDIF 10 CONTINUE 30 CONTINUE IF(NBVMAX.LT.0)GOTO 9999 C ------------------------------------ C ---- ON TRIE ET ON SUPPRIME LES DOUBLONS ---- C ------------------------------------ ITRAV = IVOIS + NBV IF( (NITMAX - ITRAV).LT.NBV )THEN IERR = -2 GOTO 9999 ENDIF C IF( NBVMAX.EQ.0)THEN C --- ON NE FAIT QUE COMPTER --- CALL TBVTAB(ITVL(IVOIS),NBV,ITVL(ITRAV), > ITVL(IVOIS),NBVOIS,NBVMAX,IERR) ELSE C --- ON REMPLI LE TABLEAU : ITVOIS --- CALL TBVTAB(ITVL(IVOIS),NBV,ITVL(ITRAV), > ITVOIS,NBVOIS,NBVMAX,IERR) ENDIF * on a maintenant les noeuds distincts dans ITVOIS 9999 CONTINUE END C C C C C SUBROUTINE RFNOTS(INOEUD,NBTEL,ITRNOE,NBNMAX,ITRTRI,NBCMAX, > COORD,IDIMC,TVALNO,NBVAL, > ITVL,NITMAX, > VALNO,IERR) C ***************************************************************** C OBJET RFNOTS : RENVOI LA TS AU NOEUD A PARTIR DES TS DES KPPV (LOCAL) C appele dans rf_raf3d.f C ***************************************************************** INTEGER INOEUD,NBTEL INTEGER ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX,ITVL(*),NITMAX REAL COORD(*),TVALNO(*) INTEGER IDIMC,NBVAL REAL VALNO INTEGER IERR C INTEGER ITVOIS,NBVOIS,NBVMAX,NTVMAX C * pour tester la memoire : ITVL(NITMAX-1) = 0 * ITVOIS = NITMAX / 2 NBVOIS = 0 NBVMAX = NITMAX / 2 NTVMAX = NITMAX - NBVMAX CALL SXNOVO(INOEUD,NBTEL,ITRNOE,NBNMAX,ITRTRI,NBCMAX, > ITVL,NTVMAX, > ITVL(ITVOIS),NBVMAX,NBVOIS,IERR) IF(IERR.NE.0)THEN CALL DSERRE(1,IERR,' ','APPEL SXNOVO : CALCUL DES VOISINS') GOTO 9999 ENDIF IF(NBVOIS.EQ.0)THEN IERR = -1 CALL DSERRE(1,IERR,' ','PAS DE NOEUD VOISIN!') GOTO 9999 ENDIF CALL SUTSNO(INOEUD,ITVL(ITVOIS),NBVOIS,COORD,IDIMC,TVALNO,NBVAL, > VALNO,IERR) IF(IERR.NE.0)THEN CALL DSERRE(1,IERR,' ','APPEL SUTSNO : CALCUL DE LA TS') GOTO 9999 ENDIF 9999 CONTINUE END C C C SUBROUTINE RFRECH(IDIMC,ITRNOE,NBNMAX,NBE,COORD,SPH, > NBSMAX,IT,XPT,COEF,IERR) C ********************************************************************** C OBJET RFRECH : RECHERCHE DE L'ELEMENT A RAFINER (LOCAL) C EN ENTREE : C COORD : COORDONNEES DES POINTS C IDIMC : DIMENSION DE L'ESPACE C ITRNOE,NBNMAX : SOMMETS DES ELEMENTS C NBE : NOMBRE D'ELEMENTS C SPH,NBSMAX : CERCLES CIRCONSCRITS AUX ELEMENTS C C EN SORTIE : C IT : L'ELEMENT A REFFINER C XPT : LE POINT A AJOUTER C COEF : LA VALEUR DU RAFFINEMENT [0-1] C PLUS COEF EST PETIT PLUS ON RAFFINE C IERR : CODE D'ERREUR (INUTILISE) C ********************************************************************** REAL COORD(*),SPH(*) INTEGER IDIMC,ITRNOE(*),NBNMAX,NBE,NBSMAX,IT,IERR REAL COEF,XPT(*) C INTEGER I,NUMP3,INDICE REAL CLRC,LRCMIN,XDEMI C INDICE = IDIMC + 1 LRCMIN = 1.0 XDEMI = 0.5 IT = 0 C --- RECHERCHE DU PLUS PETIT DIAMETRE --- DO 10 I=1,NBE CLRC = SPH((I-1)*NBSMAX+INDICE) IF( CLRC .LT. LRCMIN )THEN IT = I LRCMIN = CLRC ENDIF 10 CONTINUE C IF( IT.EQ. 0 )THEN COEF = 1. GOTO 9999 ENDIF C --- CENTRE = PT3 + SPH / 2 ------------------ CALL MUSCVE(SPH((IT-1)*NBSMAX+1),XDEMI,IDIMC,XPT) NUMP3 = ITRNOE((IT-1)*NBNMAX+INDICE) CALL SOMMVE(COORD((NUMP3-1)*IDIMC+1),XPT,IDIMC,XPT) C COEF = LRCMIN 9999 END C SUBROUTINE RFITER(FADEC,ITAB,RTAB,IMODE, > ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,NOEMAX, > COORD,IDIMC,NBN,NBE,NBPMAX,NBEMAX, > ITVL,IMAX,RTVL,IRMAX,NBENEW,IERR) C ***************************************************************** C OBJET RFITER : RAFFINE ITERATIVEMENT UN MAILLAGE TRIANGULAIRE (LOCAL) C EN ENTREE C --------- LE DECOUPAGE ------------------- C FADEC : FONCTION D'EVALUATION DU DECOUPAGE ET DE C CALCUL D'UN NOEUD, ELLE A LE FORMAT SUIVANT : C C FADEC(IT,ITRNOE,NBNMAX,ITRTRI,NBCMAX, C COORD,IDIMC,SPH,NBSMAX,ITAB,RTAB,COEF,TS,IERR) C CF. D2IDEF C C ITAB : PARAMETRES ENTIERS DE LA FONCTION FADEC C RTAB : PARAMETRES REELS DE LA FONCTION FADEC C IMODE : IL Y A 3 MODES DE FONCTIONNEMENT C (1) LE MODE DEFAUT SIMPLE C (2) LE MODE CONCENTRATIONS(X,Y) C (3) LE MODE VALEURS NODALES C C --------- TABLEAUX DE TRAVAIL ------------------- C ITVL : TABLEAU DE TRAVAIL (6*NBADET+10) C IMAX : TAILLE DU TABLEAU DE TRAVAIL C RTVL : TABLEAU DE TRAVAIL COORDONNEES + SPHERES C IRMAX : TAILLE DE RTVL >= 3*(3*NBNPTMAX-2*NBN+NBE) C --------- LE MAILLAGE --------------------- C ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,NOEMAX,NBN,NBE : LE MAILLAGE C COORD,IDIMC: LES COORDONNEES DES NOEUDS C NBPMAX : NOMBRE MAXIMUM DE POINTS C NBEMAX : NOMBRE MAXIMUM D'ELEMENTS C C EN SORTIE : LE MAILLAGE MODIFIE C NBN : LE NOMBRE DE NOEUDS = NBP + NBPNEW C NBE : LE NOMBRE D'ELEMENTS = 2 * NBPNEW + NBE C NBENEW : LE NOMBRE D'ELEMENTS GENEREES = 2 * NBPNEW C IERR : CODE D'ERREUR C 2 LE NOMBRE D'ELEMENTS MAXIMUM EST ATTEINT (MEMOIRE) C 1 LE NOMBRE DE NOEUDS MAXIMUM (DONNE) EST ATTEINT C 0 LA TAILLE SOUHAITEE EST ATTEINTE C -1 TOUS LES POINTS N'ONT PAS PU ETRE AJOUTES C -2 ITVL OU RTVL TROP PETIT C REMARQUES : C NBPNEW : LE NOMBRE DE NOEUDS GENERES = NBENEW / 2 C ********************************************************************** INTEGER ITAB(*),IMODE REAL RTAB(*) INTEGER NBE,NBEMAX,ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX INTEGER ITVL(*),IMAX INTEGER IDIMC,NOETRI(*),NOEMAX,NBN,NBPMAX,IRMAX,NBENEW,IERR REAL COORD(*),RTVL(*) EXTERNAL FADEC C C --- POUR LES STATS --- C COMMON /STATS/ ICARD(100) INTEGER ICARD C --- CONSTANTES --- INTEGER NADMAX PARAMETER ( NADMAX = 50 ) REAL ZEROTR PARAMETER ( ZEROTR = 1.E-30 ) C --- VARIABLES INTERNES --- REAL XPT(3) INTEGER IDE,NCOORD,MODAJT,I,J,IPT,NBTGEN INTEGER ISPH INTEGER NCFMAX,ICOORD INTEGER IT,IPTNEW REAL COEF,SZERO,TS,COEF2,COEFX,COEFMX INTEGER NBSMAX,NBTNEW,ITRACE,NBVAL REAL COEF3,DFRMIN,VALNO C --- COEF3 = SQRT(3) ------------ DATA COEF3 /1.73205080756887729352/ C --- RAPPORT MINI COEFMX = TS/TR = 1/1.5 --- DATA COEFMX/0.66666666666666666666/ C C ---- MODIF DU 09.02.1999 : O.STAB REAL SZERO2,SZERO3 PARAMETER (SZERO2 = 1.E-16,SZERO3 = 1.E-16) C * pour tester la memoire : ITVL(IMAX-1) = 0 * C C ==================================== C C ===== INITIALISATION ===== C C ==================================== C C TEST DES ENTREES C NORMALISATION DES POINTS (PTINIT) C CALCUL DES SPHERES CIRCONSCRITES C TRI DES ELEMENTS A RAFFINER C NBVAL = 1 NBENEW = 0 ITRACE = 1 NBSMAX = IDIMC+1 IERR = 0 IPTNEW = 0 IDE = IDIMC NCOORD = NBN C --- MODE D'AJOUT DU POINT : ON NE FORCE PAS --- MODAJT = 0 NBSMAX = IDIMC+1 IF(IDIMC.EQ.2)THEN C SZERO = 1.E-8 SZERO = SZERO2 C THEORIQUE 60 DEG : C COEFX = 9.0 / 8.0 C THEORIQUE 30 DEG : DT > 2 RC SINT(TETA)**2 C RC > 3/4 TS C COEFX = 3/2 SIN(TETA)**2 COEFX = 0.375 ELSE C --- IDIMC = 3 --- C SZERO = 1.E-8 SZERO = SZERO3 C THEORIQUE 60 DEG : C COEFX = 1.0 C EMPIRIQUE 30 DEG: COEFX = 0.5 ENDIF C LE NOMBRE MAXIMUM DE NOEUDS DONNE PAR L'UTILISATEUR EST ATTEINT C IF( NBN.EQ.NBPMAX )THEN IERR = 1 GOTO 9999 ENDIF C IF((NBN.EQ.0).OR.(IDIMC.LT. 2).OR.(IDIMC.GT. 3))THEN IERR = -1 CALL DSERRE(1,IERR,'RFITER',' DONNEES INCORRECTES ') C PRINT *,'NBN,IDIMC = ',NBN,IDIMC GOTO 9999 ENDIF IF((NBNMAX.LT.IDE).OR.(NBCMAX.LT.IDE))THEN IERR = -1 CALL DSERRE(1,IERR,'RFITER',' DONNEES INCOMPATIBLES ') C PRINT *,'NBNMAX,NBCMAX,IDE = ',NBNMAX,NBCMAX,IDE GOTO 9999 ENDIF C ISPH = (IDIMC * NBPMAX) + 1 ICOORD = 1 IF( (IRMAX-ISPH).LT.(NBE*NBSMAX))THEN IERR = -2 CALL DSERRE(1,IERR,'RFITER',' TABLEAU DES REELS ') GOTO 9999 ENDIF C CALL PTINIT(COORD,IDIMC,NBN,ZEROTR,RTVL(ICOORD),IERR) C --- ON NE NORMALISE PAS POUR POUVOIR DEBUGGER --- CALL COPIVE(COORD,(NBN*IDIMC),RTVL(ICOORD)) C ---------------------------------------------------- C --- CALCUL DES SPHERES ET DES COEFICIENTS DES ELEMENTS ------ C ---------------------------------------------------- DO 20 I=1,NBE C CALL SPCRSX(IDIMC,I,ITRNOE((I-1)*NBNMAX+1),RTVL(ICOORD), C C REMPLACE : O.STAB, 10.97, V.2.0.0 C CALL SPCREE(IDIMC,I,ITRNOE((I-1)*NBNMAX+1),RTVL(ICOORD), > RTVL(ISPH),ZEROTR,IERR) C IF( IERR .NE. 0 )THEN CALL DSERRE(1,IERR,'RFITER',' APPEL SPCREE') C PRINT *,'ELEMENT = ',I GOTO 9999 ENDIF CALL FADEC(I,ITRNOE,NBNMAX,ITRTRI,NBCMAX, > RTVL(ICOORD),IDIMC,RTVL(ISPH),NBSMAX, > ITAB,RTAB,COEF,TS,IERR) * RTVL((I-1)*NBSMAX+ISPH+2) = COEF RTVL((I-1)*NBSMAX+ISPH+IDIMC) = COEF C IF( IERR .NE. 0 )THEN CALL DSERRE(1,IERR,'RFITER', > 'APPEL FADEC (CALCUL DE LA TAILLE SOUHAITE)') GOTO 9999 ENDIF 20 CONTINUE C -------- POUR LE DEBUG --------------- NCFMAX = IDE IF( ITRACE.NE.0 )THEN C PRINT *,'VERIF TRIANGULATION INITIALE' IF( IERR .NE. 0 )THEN GO TO 9999 ENDIF ENDIF C C NBSMAX = 3 IPT = NBN C C ==================================== C C ===== BOUCLE SUR LES ELEMENTS A RAFFINER ===== C C ==================================== C 30 CONTINUE IERR = 0 C ------------------ C ---- CHOIX DE L'ELEMENT ---------------------- C ------------------ CALL RFRECH(IDIMC,ITRNOE,NBNMAX, > NBE,RTVL(ICOORD),RTVL(ISPH), > NBSMAX,IT,XPT,COEF,IERR) C C IF( ITRACE.NE.0 ) C > PRINT *,' IT =',IT,' 2*L/RC =',COEF,' XPT = ',(XPT(J),J=1,IDIMC) C ------------------------------------------------ C ---- SORTIE DE BOUCLE : PLUS D'ELEMENTS A RAFFINER --- C ------------------------------------------------ IF((IT.EQ.0).OR.(COEF.GT.COEFMX))THEN C --- ON NE NORMALISE PAS POUR POUVOIR DEBUGGER --- IERR = 0 CALL COPIVE(RTVL,(NBN*IDIMC),COORD) C PRINT *,'NOMBRE DE NOEUD GENERES = ',NBN - NCOORD C PRINT *,'NOMBRE DE NOEUD TESTES = ',IPT - NCOORD GOTO 9999 ENDIF C ---------------------------------------------------- C --- TAILLE MINI. DES NOUVEAUX ELEMENTS ------ C ---------------------------------------------------- CALL FADEC(IT,ITRNOE,NBNMAX,ITRTRI,NBCMAX, > RTVL(ICOORD),IDIMC,RTVL(ISPH),NBSMAX, > ITAB,RTAB,COEF2,TS,IERR) C --- POUR LE DEBUG --- IF((1.-COEF2).LT.0.0001)THEN IERR = -1 CALL DSERRE(1,IERR,'RFITER', > 'TAILLE DES NOUVEAUX ELEMENTS') C PRINT *,'ERREUR ET FIN ',COEF, COEF2 CALL RFRECH(IDIMC,ITRNOE,NBNMAX, > NBE,RTVL(ICOORD),RTVL(ISPH), > NBSMAX,IT,XPT,COEF,IERR) GOTO 9999 ENDIF C ------------------------------------------------------------- C POUR EVITER LA GENERATION D'ELEMENTS APPLATIS A LA FRONTIERE C ON INTERDIT LES SURFACES TROP PETITES C SZERO = SURFACE D'UN TRIANGLE EQUILATERAL DE RAYON 0.75 * TS C TS = RAYON SOUHAITE POUR LE CERCLE CIRCONSCRIT C ------------------------------------------------------------- C SZERO = COEFX * TS**(IDIMC) DFRMIN = COEFX * TS C SZERO = 1.E-08 SZERO = SZERO2 C ---------------------------------------------------- C ---- INSERTION DANS LE MAILLAGE 2D ------ C ---------------------------------------------------- IF(NBN+1.GT.NBPMAX)THEN IERR = 1 GOTO 9999 ENDIF IPT = IPT + 1 CALL S0AJNO(XPT,RTVL(ICOORD),IDIMC,NBN,NBPMAX, > NOETRI,NOEMAX,IPTNEW,IERR) IF( IERR.NE.0 )THEN CALL DSERRE(1,IERR,'RFITER','APPEL S0AJNO') ENDIF IF( ITRACE .NE. 0 )THEN C PRINT *,'*********************' C PRINT *,'AJOUT DU POINT :',IPTNEW ENDIF C C IF( IPTNEW.GE.5403 )THEN C ---- POUR LE DEBUG --- C PRINT *,'VERIF TRIANGULATION ' C CALL SDBTRI(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI, C > NBE,NBN,ITRACE,IERR) C CALL SDBORI(IDE,IDIMC,ITRNOE,NBNMAX,ITRTRI,NBCMAX, C > NOETRI,NBE,RTVL(ICOORD),ITRACE,IERR) C ENDIF C IF(IDIMC.EQ.2)THEN CALL TRAJPO(IPTNEW,IT,ITRNOE,NBNMAX,ITRTRI, > NBCMAX,NOETRI,NBE,RTVL(ICOORD),RTVL(ISPH), > NBSMAX,ITVL,IMAX,SZERO,DFRMIN,NBTNEW,IERR) ELSE CALL TTAJPO(IPTNEW,IT,ITRNOE,NBNMAX,NBEMAX,ITRTRI, > NBCMAX,NOETRI,NBE,RTVL(ICOORD),RTVL(ISPH), > NBSMAX,ITVL,IMAX,SZERO,DFRMIN,MODAJT,NBTNEW,IERR) ENDIF C IF( IERR.NE.0 )THEN IF( IERR.EQ.-2 )THEN CALL DSERRE(1,IERR,'RFITER','APPEL TTAJPO ') GOTO 9999 ENDIF IF( IERR.EQ.-1 )THEN CALL DSERRE(1,IERR,'RFITER','APPEL TTAJPO ') C ---- POUR LE DEBUG --- C PRINT *,'VERIF TRIANGULATION ' C CALL SDBTRI(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI, C > NBE,NBN,ITRACE,IERR) C CALL SDBORI(IDE,IDIMC,ITRNOE,NBNMAX,ITRTRI,NBCMAX, C > NOETRI,NBE,RTVL(ICOORD),ITRACE,IERR) GOTO 9999 ENDIF C IF( IERR.EQ.1 )THEN C --- L'ELEMENT NE PEUT PAS ETRE RAFFINE --- C PRINT *,'RFITER : REJET DU POINT ',IPTNEW RTVL((IT-1)*NBSMAX+ISPH+IDIMC) = 1. C PRINT *,'NBN = ',NBN C PRINT *,' CONNECTE A : ',NOETRI(IPTNEW) CALL S0DTNO(IPTNEW,RTVL(ICOORD),IDIMC,NBN,NBPMAX, > NOETRI,NOEMAX,IERR) IERR = 0 ENDIF C IF( IERR.EQ.2 )THEN C --- L'ELEMENT NE PEUT PAS ETRE RAFFINE --- CALL DSERRE(1,-IERR,'RFITER','APPEL TTAJPO ') C PRINT *,'RFRAFF : PLUS DE PLACE POUR LES ELEMENTS ' C PRINT *,'NBE =',NBE,' EST PROCHE DE NBEMAX =',NBEMAX C PRINT *,'NBN = ',NBN CALL COPIVE(RTVL,(NBN*IDIMC),COORD) GOTO 9999 ENDIF ELSE C ---------------------------------------------------- C --- MISE A JOUR DES COEFICIENTS DES NOUVEAUX ELEMENTS ------ C ---------------------------------------------------- C AJOUT D'UNE LIGNE POUR LA MISE A JOUR DES CHAMPS POINTS C C IF(IMODE.EQ.3)RTAB(IPTNEW) = TS C remplace le 02.03.2001 par O.STAB par : IF(IMODE.EQ.3)THEN CALL RFNOTS(IPTNEW,NBTNEW,ITRNOE,NBNMAX,ITRTRI,NBCMAX, > RTVL(ICOORD),IDIMC,RTAB,NBVAL, > ITVL,IMAX, > VALNO,IERR) IF( IERR.NE.0 )THEN CALL DSERRE(1,-IERR,'RFITER','APPEL RFNOTS ') GOTO 9999 ENDIF C PRINT *,'IPTNEW = ',IPTNEW,' VALNO = ',VALNO RTAB(IPTNEW) = VALNO ENDIF C NBENEW = NBENEW + NBTNEW DO 40 I=1,NBTNEW CALL FADEC(I,ITRNOE,NBNMAX,ITRTRI,NBCMAX, > RTVL(ICOORD),IDIMC,RTVL(ISPH),NBSMAX, > ITAB,RTAB,COEF,TS,IERR) RTVL((I-1)*NBSMAX+ISPH+IDIMC) = COEF 40 CONTINUE ENDIF C -------- POUR LE DEBUG --------------- NCFMAX = IDE IF( ITRACE .NE. 0 )THEN IF( IERR .NE. 0 )THEN GO TO 9999 ENDIF ENDIF C -------- FIN POUR DEBUG --------------- IF( IPTNEW .LT. NBPMAX )GO TO 30 C C ==================================== C C ===== FIN ===== C C ==================================== C C PRINT *,' NOMBRE MAXIMUM DE NOEUDS GENERES',IPTNEW C --- ON NE NORMALISE PAS POUR POUVOIR DEBUGGER --- IERR = 1 CALL COPIVE(RTVL,(NBN*IDIMC),COORD) C 9999 END C C C SUBROUTINE RFRAFF(IMODE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,NOEMAX, > COORD,IDIMC,NBN,NBE,NBPMAX,NBEMAX, > FADEC,ITAB,NIADEC,RTAB,IRADEC,NFADEC, > ITVL,NITMAX,RTVL,NRTMAX,IERR) C ********************************************************************** C OBJET RFRAFF : RAFFINE UNE TRIANGULATION PLANE. C C EN ENTREE : C --------- LE MAILLAGE --------------------- C ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,NOEMAX,NBN,NBE : LE MAILLAGE C COORD,IDIMC: LES COORDONNEES DES NOEUDS C NBPMAX : NOMBRE MAXIMUM DE POINTS C NBEMAX : NOMBRE MAXIMUM D'ELEMENTS C C ---- DEFINITION DU RAFFINEMENT -------------- C FADEC : C ITAB((I-1)*NIADEC+1) : PARAMETRES ENTIERS DU IEME RAFFINEMENT C NIADEC : NOMBRE MAX. DE PARAMETRES ENTIERS C RTAB((I-1)*NIADEC+1) : PARAMETRES REELS DU IEME RAFFINEMENT C IRADEC : NOMBRE MAX. DE PARAMETRES REELS C NFADEC : NOMBRE DE RAFFINEMENTS C C ---- TABLEAUX DE TRAVAIL -------------------- C ITVL : SERT POUR TAJPOT C NITMAX : TAILLE DE (6*NBADET+10) (CF. TAJPOT) C RTVL : TABLEAU DE REELS POUR LES CALCULS C NRTMAX : TAILLE DE RTVL (8*NBNPMAX+244) C C EN SORTIE : LE MAILLAGE MODIFIE C NBE,NBN : LE NOMBRE DE TRIANGLES ET DE NOEUDS APRES GENERATION C IERR : C MAILLAGE CORRECT C 2 LE NOMBRE D'ELEMENTS MAXIMUM EST ATTEINT (MEMOIRE) C 1 LE NOMBRE DE NOEUDS MAXIMUM (DONNE) EST ATTEINT C 0 OK C MAILLAGE INCORRECT C -1 SI DONNEES INCORRECTES C -2 SI TABLEAUX INSUFFISANTS C C REMARQUES : C - LES NOEUDS CALCULES SONT AJOUTES A LA TRIANGULATION C PAR LA METHODE DE DELAUNAY (APPEL TAJPOT) C - on applique dans l'ordre les fonctions de densite. C - APPEL RFITER. C ********************************************************************** INTEGER IMODE,NBE,NBEMAX,ITRNOE(*),NBNMAX,ITRTRI(*),NBCMAX INTEGER NOETRI(*),NOEMAX,NBN,NBPMAX REAL COORD(*) INTEGER IDIMC,ITAB(*),NFADEC,NIADEC,IRADEC INTEGER ITVL(*) REAL RTAB(*),RTVL(*) INTEGER NITMAX,NRTMAX,IERR EXTERNAL FADEC C INTEGER NBENEW,I,ITZERO(1) C INTEGER DNIDEF,D2IDEF EXTERNAL DNIDEF REAL VZERO(1) C IERR = 0 NBENEW = 0 IF(IMODE.EQ.1)THEN VZERO(1) = 0.0 ITZERO(1) = 0 C CALL RFITER(DNIDEF,0,ZERO,IMODE, CALL RFITER(DNIDEF,ITZERO,VZERO,IMODE, > ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,NOEMAX, > COORD,IDIMC,NBN,NBE,NBPMAX,NBEMAX, > ITVL,NITMAX,RTVL,NRTMAX,NBENEW,IERR) GOTO 9999 ENDIF C IF( IMODE.GE.2)THEN C --- A REVOIR --- DO 10 I=1,NFADEC CALL RFITER(FADEC, > ITAB((I-1)*NIADEC+1),RTAB((I-1)*IRADEC+1), > IMODE, > ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,NOEMAX, > COORD,IDIMC,NBN,NBE,NBPMAX,NBEMAX, > ITVL,NITMAX,RTVL,NRTMAX,NBENEW,IERR) IF( IERR.NE.0 )GOTO 9999 10 CONTINUE GOTO 9999 ENDIF C IERR = -1 CALL DSERRE(1,IERR,'RFRAFF',' MODE DE RAFFINEMENT') C 9999 END C