C FACGEN SOURCE CHAT 06/08/24 21:34:13 5529 SUBROUTINE FACGEN (MYMOD,INFOEL,LRES,XDEC,IAXE,INOR,ICHFAC & ,EXTINC) IMPLICIT INTEGER(I-N) IMPLICIT REAL*8 (A-H,O-Z) C---------------------------------------------------------------------- C 03/96 l'hemicube est defini dans le repere local a la face "1" C C Calcul des facteurs de forme OPTION CACHE 3D C SP APPELE PAR FACFOR C entree: C MYMOD : objet modèle C INFOEL : segment décrivant la nature des éléments des maillages C LRES : parametre de resolution C XDEC : parametre de decoupage C IAXE : pointeur sur le LISTEN contenant les pointeurs des C points definissant le plan de symetrie C INOR : parametre de normalisation et impression C sortie: C ICHFAC : chamelem facteur de forme C---------------------------------------------------------------------- -INC CCOPTIO -INC SMCOORD POINTEUR MYMOD.MMODEL -INC TFFOR3D C-------------------------------------------------------------- C FACTEURS DE FORME C NNBEL1 = NOMBRE DE LIGNES + 1 C NBEL2 = NOMBRE DE COLONNES C LFACT(NNBEL1) POINTE SUR LE TABLEAU DES SURFACES C SEGMENT IFACFO INTEGER LFACT(NNBEL1) ENDSEGMENT SEGMENT LFAC REAL*8 FACT(NBEL2) ENDSEGMENT POINTEUR PSUR.LFAC, PLIG.LFAC POINTEUR PCOL.LFAC C-------------------------------------------------------------- SEGMENT SPROGP INTEGER MKF(MPT),MICOO(2,MPT) REAL*8 MXR(3,MPT) ENDSEGMENT C-------------------------------------------------------------- SEGMENT SKCEL INTEGER KBCEL(NR,NR),IINT(2,NSTAC),IS(NSTAC),JS(NSTAC) REAL*8 RMAX ENDSEGMENT C-------------------------------------------------------------- C segment qui va contenir les coordonnées du plan de symétrie SEGMENT ,LISTEN INTEGER LECT(NBE) ENDSEGMENT POINTEUR IAXE.LISTEN C-------------------------------------------------------------- C DIMENSION U1(4),U2(4) DIMENSION O1(3) DIMENSION A1(3,3),A2(3,3) DIMENSION UA(3),UN(3),UU2(4),AA2(3,3) C** changement de repere DIMENSION HCM(3,3),OH(3),AH1(3,3),UH1(4) DIMENSION AH2(3,3),UH2(4),AAH2(3,3),UUH2(4) C** C C-------------------------------------------------------------- C * Definition du common CKRESO KFC=6 NRES = LRES KES = IDIM KIMP = IIMPI NSOM=3 C C-----PLAN DE SYMETRIE----------------------------------------------- IF (IAXE.NE.0) THEN C A partir des trois points definissant le plan , on va garder C une normale et le premier point SEGACT IAXE IF (IIMPI.GE.1) THEN WRITE(6,*) ' CALCUL AVEC PLAN DE SYMETRIE ' ENDIF DO 100 IP= 1,NSOM C On boucle sur les points IREF = (IDIM+1)*(IAXE.LECT(IP)-1) DO 101 IIES= 1,IDIM C On boucle sur les coordonnées A1(IIES,IP) = XCOOR(IREF+IIES) C (boucle : pas de défaut de page pour un tableau 3*3 de réels) 101 CONTINUE 100 CONTINUE SEGDES IAXE CALL KNORM(IDIM,A1,IDIM,U1,SSS) DO 102 IIES = 1,IDIM UA(IIES) = A1(IIES,1) UN(IIES) = U1(IIES) 102 CONTINUE IF(KIMP.GE.2) THEN WRITE(6,*) ' plan de symetrie ' WRITE(6,*) ' point ',(UA(I),I=1,IDIM) WRITE(6,*) ' normale ',(UN(I),I=1,IDIM) ENDIF ENDIF C-----PLAN DE SYMETRIE----------------------------------------------- EPS = 1D-5 C C C>>> PREPARATION C CALL KALPRE(MYMOD,INFOEL,SKFACE,XDEC,NELD) C C>>> INITIALISATION DES OBJETS DE TRAVAIL C NBEL1 = NELD NNBEL1 = NELD+1 NBEL2 = NELD SEGINI IFACFO DO 900 LS=1,NNBEL1 SEGINI PLIG LFACT(LS) = PLIG SEGDES PLIG 900 CONTINUE PSUR = LFACT(NNBEL1) SEGACT PSUR*MOD SEGACT SKFACE*MOD MFACE = NUK(/2) DO 910 K1 = 1,MFACE I1 = KCORR(K1) PSUR.FACT(I1) = PSUR.FACT(I1) + S(K1) 910 CONTINUE NR=NRES NES=KES NFC=KFC SEGINI SHC3D IF(KIMP.GE.2) THEN WRITE(6,*) ' SHC3D ',SHC3D ENDIF CALL KCACUB(NES,NR,G,V,NFC,KRO,KSI,IR) CALL KHCDAT(NR,KA,IM) NSTAC = NR*NR SEGINI SKCEL NFC = KRO(/1) NOC = 8 RMAX = 0.9 SEGINI SKBUFF MPT = 3 SEGINI SPROGP NSE = 3 NIMAX = 10*NR NSCEL = NIMAX SEGINI SPROJA C CALCUL C ------ CALL KFALIM(MFACE,K1D,K1F) DO 300 K1 = K1D,K1F I1 = KCORR(K1) IF (IIMPI.GE.4) WRITE(6,*) 'La facette',K1, # 'appartient à l élmt',I1 PLIG = LFACT(I1) SEGACT PLIG*MOD SREL = S(K1)/PSUR.FACT(I1) DO 312 K=1,IDIM+1 U1(K) = U(K,K1) 312 CONTINUE DO 201 ISS = 1,NSOM IREF = (IDIM+1)*(NUK(ISS,K1)-1) DO 202 K = 1,IDIM A1(K,ISS) = XCOOR(IREF+K) 202 CONTINUE 201 CONTINUE C** repere local a l'HC CALL KREPER(IDIM,NSOM,U1,A1,HCM) IPATCH = KPATCH(K1) SEGACT IPATCH NPATCH = GP(/2) CALL KTYPKS(NPATCH,KS1D,KS1F) DO 310 KS1 = KS1D,KS1F IF (IIMPI.GE.4) WRITE(6,*) ' K1 KS1 NPATCH ',K1,KS1,NPATCH DO 311 K=1,IDIM O1(K) = GP(K,KS1) 311 CONTINUE IF (IIMPI.GE.4) WRITE(6,*) K1, # KS1,' O1 ',(O1(I1),I1=1,IDIM) CALL KINBUF(SKBUFF) C C O1 est le point de vue sur la surface 1 C coordonnées dans le repere local OH(1)=0.D0 OH(2)=0.D0 OH(3)=0.D0 CALL KCHREP(IDIM,NSOM,O1,A1,U1,AH1,UH1,HCM) CALL KINPRO(UH1,SHC3D,SKBUFF) CALL KVERIF(SHC3D,SKBUFF) C 2eme boucle sur les faces C ------------------------- C RAPPEL: C CAS TRAITES KVU = 1 : TRAITEMENT COMMUN C KVU = 2 ET KSIG..=1 ----------------- C DO 400 K2 = 1,MFACE IF(KIMP.GE.4) THEN write(6,*) write(6,*) ' K1 K2 ',K1,K2 ENDIF C DO 412 K=1,IDIM+1 U2(K) = U(K,K2) 412 CONTINUE DO 211 ISS = 1,NSOM IREF = (IDIM+1)*(NUK(ISS,K2)-1) DO 212 K = 1,IDIM A2(K,ISS) = XCOOR(IREF+K) 212 CONTINUE 211 CONTINUE C coordonnées dans le repere local CALL KCHREP(IDIM,NSOM,O1,A2,U2,AH2,UH2,HCM) CNNN------SEQUENCE POUR LA FACE K2--------------------------------- C C>>> VISIBILITE A PRIORI C C** CALL KPRIOR(IDIM,NSOM,NSOM,A1,A2,U1,U2,KVU) CALL KPRIOR(IDIM,NSOM,NSOM,AH1,AH2,UH1,UH2,KVU) C IF (KVU.NE.0) THEN C** C = U2(IDIM+1) C = UH2(IDIM+1) C DO 401 IIES = 1,IDIM C** C = C + U2(IIES)*O1(IIES) C inutile C = C + UH2(IIES)*OH(IIES) C401 CONTINUE IF ((KVU.NE.2).OR.(KSIG(C,EPS).EQ.1)) THEN C** CALL KPROJF(O1,A2,K1,K2,C,U2,SHC3D,SKCEL,SKBUFF,SPROGA,SPROGP) CALL KPROJF(OH,AH2,K1,K2,C,UH2,SHC3D,SKCEL,SKBUFF,SPROJA,SPROGP) ENDIF ENDIF CNNN--FIN SEQUENCE POUR LA FACE K2--------------------------------- C IF (IAXE.NE.0) THEN CNNN------SEQUENCE POUR LA FACE SYMETRIQUE DE K2 ------------------ C LE PLAN SE SYMETRIE EST DEFINI PAR UN POINT UA C UNE NORMALE UNITAIRE UN C CALCUL DES SYMETRIQUES DE U2 ET A2(SOMMETS) C KES1 = IDIM + 1 CALL KSYM(IDIM,KES1,A2,U2,AA2,UU2,UA,UN) C coordonnées dans le repere local CALL KCHREP(IDIM,NSOM,O1,AA2,UU2,AAH2,UUH2,HCM) C** CALL KPRIOR(IDIM,NSOM,NSOM,A1,AA2,U1,UU2,KVU) CALL KPRIOR(IDIM,NSOM,NSOM,AH1,AAH2,UH1,UUH2,KVU) IF (KVU.NE.0) THEN C** C = UU2(IDIM+1) C = UUH2(IDIM+1) CC DO 402 IIES = 1,IDIM C** C = C + UU2(IIES)*O1(IIES) C inutile C = C + UUH2(IIES)*OH(IIES) C402 CONTINUE IF ((KVU.NE.2).OR.(KSIG(C,EPS).EQ.1)) THEN C** CALL KPROJF(O1,AA2,K1,K2,C,UU2,SHC3D,SKCEL,SKBUFF,SPROJA,SPROGP) CALL KPROJF(OH,AAH2,K1,K2,C,UUH2 & ,SHC3D,SKCEL,SKBUFF,SPROJA,SPROGP) ENDIF ENDIF CNNN--FIN SEQUENCE POUR LA FACE SYMETRIQUE DE K2------------------- ENDIF 400 CONTINUE C C>>> RECOMBINAISON C SSP1 = SP(KS1) CALL KRCOMB(K1,SSP1,SHC3D,SKFACE,SKBUFF,EXTINC) IF (K1F.NE.MFACE) THEN FFFT = 0.D0 DO 420 K2=1,MFACE FFFT = FFFT + FF1(K2) 420 CONTINUE WRITE(6,*) ' ' WRITE(6,*) ' FIJ RELATIF A LA FACE (TRI3) ',K1,' SOMME ',FFFT CALL UTPRIM(FF1,MFACE) ENDIF DO 920 K2 = 1,MFACE I2 = KCORR(K2) PLIG.FACT(I2) = PLIG.FACT(I2) + FF1(K2)*SREL 920 CONTINUE 310 CONTINUE SEGDES PLIG SEGDES IPATCH 300 CONTINUE C C ------------------------------------------------------------- C SEGDES IFACFO SEGDES PSUR C SEGSUP ,SHC3D,SKCEL,SKBUFF SEGSUP ,SPROGP,SPROJA SEGSUP SKFACE C IF (K1D.NE.1.AND.K1F.NE.MFACE) CALL ARRET(0) C C>>> NORMALISATION ET SYMETRISATION C ------------------------------ IF(EXTINC.GT.1D-3) THEN INOR=0 ENDIF CALL KFN(IFACFO,INOR,KIMP) IF(KIMP.GE.3) THEN CALL PRFACF(IFACFO) ENDIF C C C>>> TRADUCTION C ---------- LTITR=1 CALL FFMCHA(MYMOD,INFOEL,IFACFO,ICHFAC,LTITR) C C Destruction de IFACFO après traduction SEGACT IFACFO NNBEL1 = LFACT(/1) DO 950 NN = 1,NNBEL1 PLIG = LFACT(NN) SEGSUP PLIG 950 CONTINUE SEGSUP IFACFO RETURN END