1 : C PSIPHI SOURCE BP208322 14/01/29 21:15:16 7921 2 : SUBROUTINE PSIPHI 3 : *********************************************************************** 4 : c OPERATEUR : PSIP 5 : c 6 : c APPEL : 7 : c CHP1 (CHP2) (CHP3) = PSIP MAIL1 MAIL2 (CRIT1) (|'DEUX' | | P1 (P2) | ); 8 : c |'TROI' | | MAIL3 | 9 : c 10 : c FONCTION : calcule les fonctions distances signées (level set) 11 : c relatives aux maillages MAIL2 (surface de fissure) 12 : c et MAIL3 en 3D (front de fissure) 13 : c ou P1 en 2D (pointe de fissure) 14 : c aux noeuds de MAIL1 (pas trop éloignés). 15 : c 16 : c CREATION : chat (16/07/2007) 17 : c MODIFS : bp (2009 -> 2012) : diverses corrections/ameliorations 18 : c repertoriees par les fiches d'anomalies/developpement 19 : c bp 14/03/2012 : on split psiphi en psiphi psip2d psip3d et 20 : c zonag2 (evolué seulement le 18/12/2013) 21 : c 22 : c TO DO : cas 3d avec plusieurs fronts (ou 1 front discontinu) 23 : c 24 : *********************************************************************** 25 : IMPLICIT REAL*8(A-H,O-Z) 26 : IMPLICIT INTEGER(I-N) 27 : -INC CCOPTIO 28 : -INC SMCOORD 29 : -INC SMELEME 30 : -INC SMCHPOI 31 : -INC CCREEL 32 : PARAMETER(NMOCLE=2) 33 : CHARACTER*4 MOCLE(NMOCLE) 34 : DATA MOCLE/'DEUX','TROI'/ 35 : 36 : if(iimpi.ge.1) write(ioimp,*)'==== ENTREE DANS PSIPHI =====' 37 : 38 : *********************************************************************** 39 : * INITIALISATIONs et LECTUREs 40 : *********************************************************************** 41 : * 42 : * calcule t'on phi? phi ET psi? phi, psi et tau? 43 : ideux=0 43 : call lirmot (mocle,nmocle,ideux,0) 44 : if (ideux.eq.2.and.idim.lt.3) then 45 : write(*,*) ' ON NE PEUT CALCULER TROIS LEVEL SET QU EN 3D !' 46 : write(*,*) ' ON CONTINUE AVEC LE CALCUL DE 2 LEVEL SET ...' 47 : ideux=1 48 : endif 49 : 50 : * lecture des points pour lesquels on veut calculer phi et psi 50 : call lirobj('MAILLAGE',ipt1,1,iretou) 51 : melmai=ipt1 52 : if(ierr.ne.0) return 52 : call change(ipt1,1) 53 : c segact ipt1 54 : c rem: inutile car change laisse ipt1 actif 55 : 56 : * lecture du maillage de la fissure 56 : call lirobj('MAILLAGE',meleme,1,iretou) 57 : melfis=meleme 58 : if(ierr.ne.0) return 59 : 60 : * lecture de la pointe de fissure (objet de type point) ou du front 61 : ip1=0 62 : ip2=0 63 : melfro=0 64 : 1 continue 65 : if (ideux.ge.1) then 66 : if (idim.eq.2) then 66 : call lirobj('POINT',ipt,0,iretou) 67 : if (iretou.ne.0) then 68 : if (ip1.eq.0) then 69 : ip1 = ipt 70 : go to 1 71 : else 72 : ip2 = ipt 73 : endif 74 : endif 75 : else 75 : call lirobj('MAILLAGE', melfro ,1,iretou) 76 : if(iretou.eq.0) write(ioimp,*) 'Il manque le maillage du front' 77 : if(IERR.NE.0) return 78 : endif 79 : endif 80 : 81 : * lecture facultative d'une longueur max (=plus grande taille des elements 82 : * concernés par la fissure) 83 : xcrit=0.D0 83 : call lirree(xcrit,0,ircrit) 84 : 85 : 86 : 87 : *********************************************************************** 88 : * CRÉATION DES MCHPOI DE SORTIE (1 POUR PSI , 2 POUR PHI, 3 POUR TAU) 89 : *********************************************************************** 90 : mpova1=0 91 : mpova2=0 92 : mpova3=0 93 : 94 : *-----PHI----- 95 : c if(idebug.eq.1) write(6,*) '----Creation de PHI----' 96 : nat=1 97 : nsoupo=1 98 : nc=1 99 : n=ipt1.num(/2) 100 : segini,mchpo2 101 : segini,msoup2 102 : mchpo2.jattri(1)=1 103 : mchpo2.ipchp(1)=msoup2 104 : mchpo2.ifopoi=ifour 105 : segdes mchpo2 106 : msoup2.igeoc=ipt1 107 : msoup2.nocomp(1)='PHI' 108 : msoup2.noharm(1)=nifour 109 : segini,mpova2 110 : msoup2.ipoval=mpova2 111 : c segdes,msoup2 112 : 113 : *-----PSI----- 114 : if (ideux.ge.1) then 115 : c if(idebug.eq.1) write(6,*) '----Creation de PSI----' 116 : segini,mchpo1 117 : segini,msoup1 118 : mchpo1.jattri(1)=1 119 : mchpo1.ipchp(1)=msoup1 120 : mchpo1.ifopoi=ifour 121 : segdes,mchpo1 122 : msoup1.igeoc=ipt1 123 : msoup1.nocomp(1)='PSI' 124 : msoup1.noharm(1)=nifour 125 : segini,mpova1 126 : msoup1.ipoval=mpova1 127 : c segdes,msoup1 128 : else 129 : msoup1 = 0 130 : endif 131 : 132 : *-----TAU----- 133 : if (ideux.ge.2) then 134 : c if(idebug.eq.1) write(6,*) '----Creation de TAU----' 135 : segini,mchpo3 136 : segini,msoup3 137 : mchpo3.jattri(1)=1 138 : mchpo3.ipchp(1)=msoup3 139 : mchpo3.ifopoi=ifour 140 : segdes,mchpo3 141 : msoup3.igeoc=ipt1 142 : msoup3.nocomp(1)='TAU' 143 : msoup3.noharm(1)=nifour 144 : segini,mpova3 145 : msoup3.ipoval=mpova3 146 : c segdes,msoup3 147 : else 148 : msoup3 = 0 149 : endif 150 : 151 : 152 : *********************************************************************** 153 : * PSIPHI 3D/2D 154 : *********************************************************************** 155 : if (idim.eq.3) then 156 : c write(ioimp,*)'appel PSIP3D (',ideux,ipt1,melfis,melfro,xcrit 156 : call PSIP3D(ideux,ipt1,melfis,melfro,xcrit, 157 : & msoup1,msoup2,msoup3) 158 : else 159 : c write(ioimp,*)'appel PSIP3D (',ideux,ipt1,melfis,ip1,ip2,xcrit 159 : call PSIP2D(ideux,ipt1,melfis,ip1,ip2,xcrit, 160 : & msoup1,msoup2) 161 : endif 162 : 163 : 164 : *********************************************************************** 165 : * ECRITURE ET FIN DU PROGRAMME 166 : *********************************************************************** 167 : 168 : c-----ecriture de (PSI) PHI ((TAU)) -------------- 168 : if(ideux.ge.2) call ecrobj('CHPOINT',mchpo3) 168 : call ecrobj('CHPOINT',mchpo2) 168 : if(ideux.ge.1) call ecrobj('CHPOINT',mchpo1) 169 : 170 : 171 : return 172 : end 173 : 174 : 175 : 176 : 177 : 178 : 179 : 180 : 181 : 182 : 183 : 184 : 185 :
© Cast3M 2003 - All rights reserved.
Disclaimer