1 : C PRELIM SOURCE FANDEUR 12/12/21 21:15:09 7634 2 : SUBROUTINE PRELIM(ICLE) 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8 (A-H,O-Z) 5 : C===================================================================== 6 : C CE SOUS PROGRAMME PREPARE LES DONNEES POUR ELIM 7 : C IL FORME LA TABLE DES POINTS A TESTER 8 : C 9 : C ICPR EST LA MOUVELLE NUMEROTATION 10 : C ICPR(ANCIEN N°)= NOUVEAU N° 11 : C ICPR(ANCIEN N°)= 0 SI LE NOEUDS N'APPARTIENT PAS AU MAILLAGE(S 12 : C ) ARGUMENT(S) 13 : C IAPOB1 EST UN TABLEAU SUR LA NOUVELLE NUMEROTATION 14 : C =1 SI LE NOEUD EST DANS LE 1ER MAILLGE =0 SINON 15 : C IAPOB2 EST UN TABLEAU SUR LA NOUVELLE NUMEROTATION 16 : C =1 SI LE NOEUD EST DANS LE 2IEME MAILLGE =0 SINON 17 : C ICLE=0 PRELIM APPELE PAR L'OPERATEUR ELIM 18 : C ICLE=1 PRELIM APPELE PAR L'OPERATEUR VISAVIS 19 : C====================================================================== 20 : 21 : -INC CCOPTIO 22 : -INC SMELEME 23 : POINTEUR MELEM2.MELEME 24 : -INC SMCOORD 25 : SEGMENT ICPR(XCOOR(/1)/(IDIM+1)) 26 : SEGMENT IAPOB1(XCOOR(/1)/(IDIM+1)) 27 : SEGMENT IAPOB2(XCOOR(/1)/(IDIM+1)) 28 : REAL*8 XXX,CRIT 29 : -INC CCGEOME 30 : -INC TMLCHA8 31 : -INC TMCOLAC 32 : -INC CCASSIS 33 : CHARACTER*8 TYPI,NOMI 34 : 35 : C RECUPERE LES ARGUMENTS 36 : 37 : IF (ICLE.EQ.0) THEN 38 : 38 : CALL QUETYP(TYPI,0,IRET) 39 : IF (IRET.EQ.0) THEN 40 : * ERREUR => "Cet opérateur a encore besoin d'un opérande." 40 : CALL ERREUR(533) 41 : RETURN 42 : ENDIF 43 : 44 : IF (TYPI.NE.'MAILLAGE' .AND. 45 : & TYPI.NE.'ENTIER' .AND. 46 : & TYPI.NE.'FLOTTANT') THEN 47 : * ERREUR => "On ne veut pas d'objet de type %m1:8" 48 : MOTERR(1:8)=TYPI 48 : CALL ERREUR(39) 49 : RETURN 50 : ENDIF 51 : 52 : ENDIF 53 : *********************************************************************** 54 : 55 : 56 : MELEME=0 57 : MELEM2=0 57 : CALL LIRREE(XXX,0,IRETOU) 58 : IF (IRETOU.NE.0)THEN 59 : CRIT=XXX 60 : ELSE 61 : CRIT=DBLE(DENSIT)/10.D0 62 : ENDIF 63 : CRIT=ABS(CRIT) 64 : C Erreur 21 : Données incompatibles 64 : IF (CRIT.EQ.0.D0) CALL ERREUR(21) 65 : IF (IERR.NE.0) RETURN 65 : CALL LIROBJ('MAILLAGE',MELEME,1,IRETOU) 66 : IF (IERR.NE.0) RETURN 66 : CALL LIROBJ('MAILLAGE',MELEM2,0,IRETOU) 67 : IF(MELEM2.EQ.0) MELEM2=MELEME 68 : * ON REMET DANS LA PILE LE DERNIER MAILLAGE LU (POUR DALLER QUEL) 68 : IF(ICLE.EQ.0) CALL REFUS 69 : if( nbesc.ne.0) then 70 : mestra=imestr 71 : SEGACT MESTRA*MOD 71 : call ooofrc(1) 71 : call setass(1) 72 : endif 73 : SEGINI ICPR 74 : SEGINI IAPOB1 75 : SEGINI IAPOB2 76 : C 77 : C BOUCLE SUR LE PREMIER MAILLAGE REMPLI ICPR ET IAPOB1 78 : C 79 : ITE=0 80 : SEGACT MELEME 81 : DO 2 I=1,MAX(1,LISOUS(/1)) 82 : IF (LISOUS(/1).NE.0) THEN 83 : IPT1=LISOUS(I) 84 : SEGACT IPT1 85 : ELSE 86 : IPT1=MELEME 87 : ENDIF 88 : DO 5 K=1,IPT1.NUM(/1) 89 : DO 51 L=1,IPT1.NUM(/2) 90 : M=IPT1.NUM(K,L) 91 : IF (ICPR(M).EQ.0) THEN 92 : ITE=ITE+1 93 : ICPR(M)=ITE 94 : ENDIF 95 : IAPOB1(ICPR(M))=1 96 : 51 CONTINUE 97 : 5 CONTINUE 98 : IF (LISOUS(/1).NE.0) SEGDES IPT1 99 : 2 CONTINUE 100 : SEGDES MELEME 101 : C 102 : C BOUCLE SUR LE DEUXIEME MAILLAGE REMPLI IPCR ET IAPOB2 103 : C 104 : SEGACT MELEM2 105 : DO 52 I=1,MAX(1,MELEM2.LISOUS(/1)) 106 : IF (MELEM2.LISOUS(/1).NE.0)THEN 107 : IPT2=MELEM2.LISOUS(I) 108 : SEGACT IPT2 109 : ELSE 110 : IPT2=MELEM2 111 : ENDIF 112 : DO 45 K=1,IPT2.NUM(/1) 113 : DO 451 L=1,IPT2.NUM(/2) 114 : M=IPT2.NUM(K,L) 115 : IF (ICPR(M).EQ.0) THEN 116 : ITE=ITE+1 117 : ICPR(M)=ITE 118 : ENDIF 119 : IAPOB2(ICPR(M))=1 120 : 451 CONTINUE 121 : 45 CONTINUE 122 : IF (MELEM2.LISOUS(/1).NE.0) SEGDES IPT2 123 : 52 CONTINUE 124 : SEGDES MELEM2 125 : C 126 : C ON DETERMINE LES POINTS SUPPORTS DES MULTIPLICATEURS DE LAGRANGE 127 : C 128 : TYPI=' ' 129 : K=-1 129 : CALL TYPFIL(TYPI,K) 129 : CALL CREPIL(ICOLAC,-K) 130 : M=1 131 : SEGINI MLCHA8 132 : MLCHAR(1)='MAILLAGE' 132 : CALL FILLPO(ICOLAC,MLCHA8) 133 : SEGSUP MLCHA8 133 : CALL FILLPI(ICOLAC) 134 : SEGACT ICOLAC 135 : C 136 : C BOUCLE SUR LES MAILLAGES ON CHERCHE LES ELEMENTS DE TYPE 22 137 : C ("MULT") 138 : C ON INDIQUE LEUR EXISTENCE DANS IAPOB1 AVEC LA VALEUR 2 139 : C 140 : ITLACC=KCOLA(1) 141 : SEGACT ITLACC 142 : DO 70 L=1,ITLAC(/1) 143 : MELEME=ITLAC(L) 144 : IF (MELEME.NE.0) THEN 145 : SEGACT MELEME 146 : DO 60 LL=1,MAX(1,LISOUS(/1)) 147 : IF (LISOUS(/1).NE.0)THEN 148 : IPT1=LISOUS(LL) 149 : SEGACT IPT1 150 : ELSE 151 : IPT1=MELEME 152 : ENDIF 153 : IF (IPT1.ITYPEL .EQ. 22)THEN 154 : DO 55 LLL=1,IPT1.NUM(/2) 155 : C LE PREMIER NOEUD SUPPORTENT LES MULTIPLICATEURS 156 : IF (ICPR(IPT1.NUM(1,LLL)) .NE. 0) 157 : $ IAPOB1(ICPR(IPT1.NUM(1,LLL)))=2 158 : 55 CONTINUE 159 : ENDIF 160 : IF (LISOUS(/1).NE.0)SEGDES IPT1 161 : 60 CONTINUE 162 : SEGDES MELEME 163 : ENDIF 164 : 70 CONTINUE 165 : C Supprime icolac et tous ses sous-objets (ITLACC...) 165 : CALL SUPPIL(ICOLAC,-1) 166 : C 166 : CALL ELIMIN(ICPR,CRIT,ITE,IAPOB1,IAPOB2,MELEME,MELEM2,ICLE) 167 : SEGSUP IAPOB2 168 : SEGSUP IAPOB1 169 : SEGSUP ICPR 170 : if(nbesc.ne.0) then 171 : mestra=imestr 171 : call ooofrc(0) 171 : call setass(0) 172 : SEGDES MESTRA 173 : endif 174 : RETURN 175 : END 176 : 177 : 178 : 179 : 180 : 181 : 182 : 183 : 184 : 185 : 186 : 187 : 188 : 189 : 190 : 191 : 192 : 193 : 194 : 195 : 196 :
© Cast3M 2003 - All rights reserved.
Disclaimer