C GENJO3 SOURCE BP208322 16/11/18 21:17:21 9177 SUBROUTINE GENJO3 C-------------------------------------------------------------------- C C MAIL1 = GENJ MAIL2 FLOT1; C C MAIL1 : MAILLAGE DE JOT3 OU JOI4 C MAIL2 : MAILLAGE DE CUB8, PRI6, PYR5 ET/OU TET4 C FLOT1 : TOLERANCE C C Pierre Pegon/JRC Ispra C-------------------------------------------------------------------- IMPLICIT INTEGER(I-N) IMPLICIT REAL*8 (A-H,O-Z) C -INC PPARAM -INC CCOPTIO -INC SMELEME -INC SMCOORD -INC CCGEOME -INC SMLENTI -INC SMLREEL C SEGMENT,JO4GEN INTEGER P4(4,NCOT4) INTEGER SZ4(NCOT4), NELM4(NCOT4) INTEGER FLA4(NCOT4) ENDSEGMENT POINTEUR JO4GE1.JO4GEN C SEGMENT,JO3GEN INTEGER P3(3,NCOT3) INTEGER SZ3(NCOT3), NELM3(NCOT3) INTEGER FLA3(NCOT3) ENDSEGMENT POINTEUR JO3GE1.JO3GEN C LOGICAL GENTST DIMENSION FAC1(3,4),FAC2(3,4),BAR1(3),BAR2(3) C IF(IIMPI.EQ.1790)THEN WRITE(IOIMP,*)'GENJO3: On entre dans la subroutine' ENDIF C CALL LIROBJ('MAILLAGE',IPT1,1,IRET) IF(IERR.NE.0) RETURN CALL LIRREE(XTOL,1,IRET) IF(IERR.NE.0) RETURN XTOL2=XTOL**2 C C VERIFICATION DE LA DIMENSION C IF (IDIM.NE.3)THEN WRITE(IOIMP,*)'GENJO3: on n"est pas en 3D' RETURN ENDIF C C VERIFICATION DES TYPES D'ELEMENT (POUR LE MOMENT CUB8, PRI6, C PYR5 ET TET4) C ET CALCUL DU NOMBRE DE COTES C NCOT4=0 NCOT3=0 SEGACT,IPT1 NBSOUS=IPT1.LISOUS(/1) DO IE1=1,MAX(NBSOUS,1) IF(NBSOUS.EQ.0)THEN MELEME=IPT1 ELSE MELEME=IPT1.LISOUS(IE1) SEGACT,MELEME ENDIF ILC=ITYPEL IF(ILC.NE.14.AND.ILC.NE.16.AND.ILC.NE.23.AND.ILC.NE.25)THEN WRITE(IOIMP,*)'GENJO3: type d"element incorrect' SEGDES,MELEME*NOMOD RETURN ELSE NBELEM=ICOLOR(/1) IF(ILC.EQ.23)THEN NCOT3=NCOT3+4*NBELEM ELSEIF(ILC.EQ.14)THEN NCOT4=NCOT4+6*NBELEM ELSEIF(ILC.EQ.16)THEN NCOT3=NCOT3+2*NBELEM NCOT4=NCOT4+3*NBELEM ELSEIF(ILC.EQ.25)THEN NCOT3=NCOT3+4*NBELEM NCOT4=NCOT4+ NBELEM ENDIF ENDIF SEGDES,MELEME*NOMOD ENDDO C IF(IIMPI.EQ.1790)THEN WRITE(IOIMP,*)'GENJO3: fin verification' ENDIF C C REMPLISSAGE DU SEGMENT DES COTES C SEGACT,IPT1 SEGINI,JO3GEN,JO4GEN IJOI3=0 IJOI4=0 DO IE1=1,MAX(NBSOUS,1) IF(NBSOUS.EQ.0)THEN MELEME=IPT1 ELSE MELEME=IPT1.LISOUS(IE1) SEGACT,MELEME ENDIF ILC=ITYPEL NBELEM=ICOLOR(/1) DO IE2=1,NBELEM IF(ILC.EQ.23)THEN CALL GF2323(P3,SZ3,NELM3,FLA3, IJOI3,3, > NUM(1,IE2),MIN(NBSOUS,IE1),IE2) ELSEIF(ILC.EQ.14)THEN CALL GF1424(P4,SZ4,NELM4,FLA4, IJOI4,4, > NUM(1,IE2),MIN(NBSOUS,IE1),IE2) ELSEIF(ILC.EQ.16)THEN CALL GF1623(P3,SZ3,NELM3,FLA3, IJOI3,3, > NUM(1,IE2),MIN(NBSOUS,IE1),IE2) CALL GF1624(P4,SZ4,NELM4,FLA4, IJOI4,4, > NUM(1,IE2),MIN(NBSOUS,IE1),IE2) ELSEIF(ILC.EQ.25)THEN CALL GF2523(P3,SZ3,NELM3,FLA3, IJOI3,3, > NUM(1,IE2),MIN(NBSOUS,IE1),IE2) CALL GF2524(P4,SZ4,NELM4,FLA4, IJOI4,4, > NUM(1,IE2),MIN(NBSOUS,IE1),IE2) ENDIF ENDDO ENDDO C IF(IIMPI.EQ.1790)THEN WRITE(IOIMP,*)'GENJO3: fin remplissage' ENDIF C C ELIMINATION DES DOUBLONS A NOEUDS IDENTIQUES C IF(NCOT3.GT.0)THEN JG=NCOT3 SEGINI,MLENTI,MLENT1 DO IE1=1,NCOT3 LECT(IE1)=IE1 MLENT1.LECT(IE1)=FLA3(IE1) ENDDO CALL GENOR2(MLENT1.LECT,LECT,NCOT3) IF(IIMPI.EQ.1790)THEN WRITE(IOIMP,*)'GENJO3: fin de mise en ordre' ENDIF IFI=MLENT1.LECT(1) DO IE1=2,NCOT3 IFF=MLENT1.LECT(IE1) IF(IFI.EQ.IFF)THEN JE1=LECT(IE1-1) IF(FLA3(JE1).NE.0)THEN DO IE2=IE1,NCOT3 IFFF=MLENT1.LECT(IE2) IF(IFI.NE.IFFF)GOTO 30 JE2=LECT(IE2) IF(FLA3(JE2).NE.0)THEN IF(GENTST(P3(1,JE1),P3(1,JE2),3))THEN FLA3(JE1)=0 FLA3(JE2)=0 GOTO 30 ENDIF ENDIF ENDDO ENDIF ENDIF 30 IFI=IFF ENDDO SEGSUP,MLENTI,MLENT1 ENDIF C IF(NCOT4.GT.0)THEN JG=NCOT4 SEGINI,MLENTI,MLENT1 DO IE1=1,NCOT4 LECT(IE1)=IE1 MLENT1.LECT(IE1)=FLA4(IE1) ENDDO CALL GENOR2(MLENT1.LECT,LECT,NCOT4) IF(IIMPI.EQ.1790)THEN WRITE(IOIMP,*)'GENJO3: fin de mise en ordre' ENDIF IFI=MLENT1.LECT(1) DO IE1=2,NCOT4 IFF=MLENT1.LECT(IE1) IF(IFI.EQ.IFF)THEN JE1=LECT(IE1-1) IF(FLA4(JE1).NE.0)THEN DO IE2=IE1,NCOT4 IFFF=MLENT1.LECT(IE2) IF(IFI.NE.IFFF)GOTO 40 JE2=LECT(IE2) IF(FLA4(JE2).NE.0)THEN IF(GENTST(P4(1,JE1),P4(1,JE2),4))THEN FLA4(JE1)=0 FLA4(JE2)=0 GOTO 40 ENDIF ENDIF ENDDO ENDIF ENDIF 40 IFI=IFF ENDDO SEGSUP,MLENTI,MLENT1 ENDIF C IF(IIMPI.EQ.1790)THEN WRITE(IOIMP,*)'GENJO3: fin elimination des doublons' ENDIF C C CONCATENATION DES LISTES C IF (NCOT3.GT.0)THEN NNCOT3=NCOT3 NCOT3=0 DO IE1=1,NNCOT3 IF(FLA3(IE1).NE.0)NCOT3=NCOT3+1 ENDDO SEGINI,JO3GE1 JE1=0 DO IE1=1,NNCOT3 IF(FLA3(IE1).NE.0)THEN JE1=JE1+1 DO IE2=1,IDIM JO3GE1.P3(IE2,JE1)=P3(IE2,IE1) ENDDO JO3GE1.SZ3(JE1)=SZ3(IE1) JO3GE1.NELM3(JE1)=NELM3(IE1) JO3GE1.FLA3(JE1)=0 ENDIF ENDDO SEGSUP,JO3GEN JO3GEN=JO3GE1 ENDIF C IF (NCOT4.GT.0)THEN NNCOT4=NCOT4 NCOT4=0 DO IE1=1,NNCOT4 IF(FLA4(IE1).NE.0)NCOT4=NCOT4+1 ENDDO SEGINI,JO4GE1 JE1=0 DO IE1=1,NNCOT4 IF(FLA4(IE1).NE.0)THEN JE1=JE1+1 DO IE2=1,4 JO4GE1.P4(IE2,JE1)=P4(IE2,IE1) ENDDO JO4GE1.SZ4(JE1)=SZ4(IE1) JO4GE1.NELM4(JE1)=NELM4(IE1) JO4GE1.FLA4(JE1)=0 ENDIF ENDDO SEGSUP,JO4GEN JO4GEN=JO4GE1 ENDIF C IF(IIMPI.EQ.1790)THEN WRITE(IOIMP,*)'GENJO3: fin concatenation' ENDIF C C DETERMINATION DES SEGMENTS AVEC VIS-A-VIS C IRET=0 IF(NCOT3.GT.1)THEN JG=NCOT3 SEGINI,MLENTI,MLREEL DO IE1=1,NCOT3 LECT(IE1)=IE1 DO IE2=1,IDIM BAR1(IE2)=0.D0 ENDDO DO IE2=1,3 IPR1=(IDIM+1)*(P3(IE2,IE1)-1) DO IE3=1,IDIM BAR1(IE3)=BAR1(IE3)+XCOOR(IPR1+IE3) ENDDO ENDDO PROG(IE1)=SQRT(BAR1(1)**2+BAR1(2)**2+BAR1(3)**2)/3 ENDDO CALL GENOS2(PROG,LECT,NCOT3) IF(IIMPI.EQ.1790)THEN WRITE(IOIMP,*)'GENJO3: fin de mise en ordre' ENDIF XFI=PROG(1) DO IE1=2,NCOT3 XFF=PROG(IE1) IF(ABS(XFI-XFF).LT.XTOL)THEN JE1=LECT(IE1-1) IF(FLA3(JE1).EQ.0)THEN DO IE2=1,IDIM BAR1(IE2)=0.D0 ENDDO DO IE2=1,3 IPR1=(IDIM+1)*(P3(IE2,JE1)-1) DO IE3=1,IDIM FAC1(IE3,IE2)=XCOOR(IPR1+IE3) BAR1(IE3)=BAR1(IE3)+FAC1(IE3,IE2) ENDDO ENDDO DO IE2=IE1,NCOT3 XFFF=PROG(IE2) IF(ABS(XFI-XFFF).GE.XTOL)GOTO 31 JE2=LECT(IE2) IF(FLA3(JE2).EQ.0)THEN DO IE3=1,IDIM BAR2(IE3)=0.D0 ENDDO DO IE3=1,3 IPR2=(IDIM+1)*(P3(IE3,JE2)-1) DO IE4=1,IDIM FAC2(IE4,IE3)=XCOOR(IPR2+IE4) BAR2(IE4)=BAR2(IE4)+FAC2(IE4,IE3) ENDDO ENDDO DIS12=0.D0 DO IE3=1,IDIM DIS12=DIS12+(BAR2(IE3)-BAR1(IE3))**2 ENDDO DIS12=DIS12/9 IF(DIS12.LT.XTOL2)THEN FLA3(JE1)=JE2 FLA3(JE2)=JE1 CALL GENRD1(FAC1,FAC2,P3(1,JE2),3,XTOL2,IRET) IF(IRET.NE.0)GOTO 9999 GOTO 31 ENDIF ENDIF ENDDO ENDIF ENDIF 31 XFI=XFF ENDDO SEGSUP,MLREEL,MLENTI ENDIF C IRET=0 IF(NCOT4.GT.1)THEN JG=NCOT4 SEGINI,MLENTI,MLREEL DO IE1=1,NCOT4 LECT(IE1)=IE1 DO IE2=1,IDIM BAR1(IE2)=0.D0 ENDDO DO IE2=1,4 IPR1=(IDIM+1)*(P4(IE2,IE1)-1) DO IE3=1,IDIM BAR1(IE3)=BAR1(IE3)+XCOOR(IPR1+IE3) ENDDO ENDDO PROG(IE1)=SQRT(BAR1(1)**2+BAR1(2)**2+BAR1(3)**2)/4 ENDDO CALL GENOS2(PROG,LECT,NCOT4) IF(IIMPI.EQ.1790)THEN WRITE(IOIMP,*)'GENJO3: fin de mise en ordre' ENDIF XFI=PROG(1) DO IE1=2,NCOT4 XFF=PROG(IE1) IF(ABS(XFI-XFF).LT.XTOL)THEN JE1=LECT(IE1-1) IF(FLA4(JE1).EQ.0)THEN DO IE2=1,IDIM BAR1(IE2)=0.D0 ENDDO DO IE2=1,4 IPR1=(IDIM+1)*(P4(IE2,JE1)-1) DO IE3=1,IDIM FAC1(IE3,IE2)=XCOOR(IPR1+IE3) BAR1(IE3)=BAR1(IE3)+FAC1(IE3,IE2) ENDDO ENDDO DO IE2=IE1,NCOT4 XFFF=PROG(IE2) IF(ABS(XFI-XFFF).GE.XTOL)GOTO 41 JE2=LECT(IE2) IF(FLA4(JE2).EQ.0)THEN DO IE3=1,IDIM BAR2(IE3)=0.D0 ENDDO DO IE3=1,4 IPR2=(IDIM+1)*(P4(IE3,JE2)-1) DO IE4=1,IDIM FAC2(IE4,IE3)=XCOOR(IPR2+IE4) BAR2(IE4)=BAR2(IE4)+FAC2(IE4,IE3) ENDDO ENDDO DIS12=0.D0 DO IE3=1,IDIM DIS12=DIS12+(BAR2(IE3)-BAR1(IE3))**2 ENDDO DIS12=DIS12/16 IF(DIS12.LT.XTOL2)THEN FLA4(JE1)=JE2 FLA4(JE2)=JE1 CALL GENRD1(FAC1,FAC2,P4(1,JE2),4,XTOL2,IRET) IF(IRET.NE.0)GOTO 9999 GOTO 41 ENDIF ENDIF ENDDO ENDIF ENDIF 41 XFI=XFF ENDDO SEGSUP,MLREEL,MLENTI ENDIF C IF(IIMPI.EQ.1790)THEN WRITE(IOIMP,*)'GENJO3: fin determination des vis-a-vis' ENDIF C C CREATION DU/DES MAILLAGE(S) DE JOINT C NBREF=0 NBSOUS=0 NBELEM=0 DO IE1=1,NCOT3 IF(FLA3(IE1).NE.0)NBELEM=NBELEM+1 ENDDO NBELEM=NBELEM/2 IF(NBELEM.NE.0)THEN NBNN=6 SEGINI,MELEME ITYPEL=18 DO IE1=1,NBELEM ICOLOR(IE1)=0 ENDDO IPT3=MELEME ELSE IPT3=0 ENDIF C NBELEM=0 DO IE1=1,NCOT4 IF(FLA4(IE1).NE.0)NBELEM=NBELEM+1 ENDDO NBELEM=NBELEM/2 IF(NBELEM.NE.0)THEN NBNN=8 SEGINI,MELEME ITYPEL=19 DO IE1=1,NBELEM ICOLOR(IE1)=0 ENDDO IPT4=MELEME ELSE IPT4=0 ENDIF C IF(IPT3*IPT4.EQ.0)THEN IF(IPT3.EQ.0.AND.IPT4.EQ.0)THEN WRITE(IOIMP,*)'GENJO3: aucun joint cree' GOTO 9999 ELSEIF(IPT3.NE.0)THEN IPT2=IPT3 ELSE IPT2=IPT4 ENDIF ELSE NBSOUS=2 NBNN=0 NBELEM=0 SEGINI,MELEME LISOUS(1)=IPT3 LISOUS(2)=IPT4 IPT2=MELEME SEGDES,MELEME ENDIF C IF(IIMPI.EQ.1790)THEN WRITE(IOIMP,*)'GENJO3: fin creation maillage' ENDIF C C GENERATION DU/DES MAILLAGE(S) DE JOINT C IF(IPT3.NE.0)THEN IELEM=0 DO IE1=1,NCOT3 IF(FLA3(IE1).NE.0)THEN IELEM=IELEM+1 * * premier barycentre * DO IE2=1,IDIM BAR1(IE2)=0.D0 ENDDO IF(SZ3(IE1).EQ.0)THEN MELEME=IPT1 ELSE MELEME=IPT1.LISOUS(SZ3(IE1)) ENDIF NBNN=NUM(/1) DO IE3=1,NBNN IPDUM=(IDIM+1)*(NUM(IE3,NELM3(IE1))-1) DO IE4=1,IDIM BAR1(IE4)=BAR1(IE4)+XCOOR(IPDUM+IE4) ENDDO ENDDO DO IE2=1,IDIM BAR1(IE2)=BAR1(IE2)/NBNN ENDDO * * Chargement de la premiere face * DO IE2=1,3 IPR1=(IDIM+1)*(P3(IE2,IE1)-1) DO IE3=1,IDIM FAC1(IE3,IE2)=XCOOR(IPR1+IE3) ENDDO ENDDO * * second barycentre * JE1=FLA3(IE1) DO IE2=1,IDIM BAR2(IE2)=0.D0 ENDDO IF(SZ3(JE1).EQ.0)THEN MELEME=IPT1 ELSE MELEME=IPT1.LISOUS(SZ3(JE1)) ENDIF NBNN=NUM(/1) DO IE3=1,NBNN IPDUM=(IDIM+1)*(NUM(IE3,NELM3(JE1))-1) DO IE4=1,IDIM BAR2(IE4)=BAR2(IE4)+XCOOR(IPDUM+IE4) ENDDO ENDDO DO IE2=1,IDIM BAR2(IE2)=BAR2(IE2)/NBNN ENDDO * * Chargement de la seconde face * DO IE2=1,3 IPR1=(IDIM+1)*(P3(IE2,JE1)-1) DO IE3=1,IDIM FAC2(IE3,IE2)=XCOOR(IPR1+IE3) ENDDO ENDDO * * On ordonne correctement les points * CALL GENRD2(FAC1,BAR1,P3(1,IE1),BAR2,P3(1,JE1),3,TOL) * * On charge le joint * DO IE2=1,3 IPT3.NUM(IE2 ,IELEM)=P3(IE2,IE1) IPT3.NUM(IE2+3,IELEM)=P3(IE2,JE1) ENDDO * * on efface les 2 cotes * FLA3(IE1)=0 FLA3(JE1)=0 ENDIF ENDDO SEGDES,IPT3 ENDIF C IF(IPT4.NE.0)THEN IELEM=0 DO IE1=1,NCOT4 IF(FLA4(IE1).NE.0)THEN IELEM=IELEM+1 * * premier barycentre * DO IE2=1,IDIM BAR1(IE2)=0.D0 ENDDO IF(SZ4(IE1).EQ.0)THEN MELEME=IPT1 ELSE MELEME=IPT1.LISOUS(SZ4(IE1)) ENDIF NBNN=NUM(/1) DO IE3=1,NBNN IPDUM=(IDIM+1)*(NUM(IE3,NELM4(IE1))-1) DO IE4=1,IDIM BAR1(IE4)=BAR1(IE4)+XCOOR(IPDUM+IE4) ENDDO ENDDO DO IE2=1,IDIM BAR1(IE2)=BAR1(IE2)/NBNN ENDDO * * Chargement de la premiere face * DO IE2=1,4 IPR1=(IDIM+1)*(P4(IE2,IE1)-1) DO IE3=1,IDIM FAC1(IE3,IE2)=XCOOR(IPR1+IE3) ENDDO ENDDO * * second barycentre * JE1=FLA4(IE1) DO IE2=1,IDIM BAR2(IE2)=0.D0 ENDDO IF(SZ4(JE1).EQ.0)THEN MELEME=IPT1 ELSE MELEME=IPT1.LISOUS(SZ4(JE1)) ENDIF NBNN=NUM(/1) DO IE3=1,NBNN IPDUM=(IDIM+1)*(NUM(IE3,NELM4(JE1))-1) DO IE4=1,IDIM BAR2(IE4)=BAR2(IE4)+XCOOR(IPDUM+IE4) ENDDO ENDDO DO IE2=1,IDIM BAR2(IE2)=BAR2(IE2)/NBNN ENDDO * * Chargement de la seconde face * DO IE2=1,4 IPR1=(IDIM+1)*(P4(IE2,JE1)-1) DO IE3=1,IDIM FAC2(IE3,IE2)=XCOOR(IPR1+IE3) ENDDO ENDDO * * On ordonne correctement les points * CALL GENRD2(FAC1,BAR1,P4(1,IE1),BAR2,P4(1,JE1),4,TOL) * * On charge le joint * DO IE2=1,4 IPT4.NUM(IE2 ,IELEM)=P4(IE2,IE1) IPT4.NUM(IE2+4,IELEM)=P4(IE2,JE1) ENDDO * * on efface les 2 cotes * FLA4(IE1)=0 FLA4(JE1)=0 ENDIF ENDDO SEGDES,IPT4 ENDIF C IF(IIMPI.EQ.1790)THEN WRITE(IOIMP,*)'GENJO3: fin chargement maillage' ENDIF C C DESTRUCTION, DESACTIVATION ET RETOUR A GIBIANE C CALL ECROBJ('MAILLAGE',IPT2) C 9999 SEGSUP,JO3GEN,JO4GEN C NBSOUS=IPT1.LISOUS(/1) DO IE1=1,MAX(NBSOUS,1) IF(NBSOUS.EQ.0)THEN MELEME=IPT1 ELSE MELEME=IPT1.LISOUS(IE1) ENDIF SEGDES,MELEME*NOMOD ENDDO C RETURN END