1 : C DALLOS SOURCE CHAT 06/03/29 21:18:13 5360 2 : C 3 : C 4 : SUBROUTINE DALLOS(IREGIO,FER,XPROJ,NBLIG,NBCOL,NKCOIN, 5 : > IPT3,NBE,NBN,IERRDS) 6 : C ********************************************************************** 7 : C OBJET DALLOS : MAILLAGE EN QUADRANGLE A PARTIR D'UN MAILLAGE 8 : C OBJET LINEIQUE DE 4 COTES FORMANT UN CONTOUR FERME. 9 : C 10 : C EN ENTREE : 11 : C IREGIO : IREGIO(I) NOMBRE D'ELEMENTS SUR LE COTE I 12 : C FER : DESCRIPTION DU CONTOUR (NUMERO DES NOEUDS) 13 : C XPROJ : COORDONNEES DES POINTS DU CONTOUR (PROJETE DANS LE PLAN) 14 : C NBLIG : NOMBRE DE LIGNE DE LA GRILLE 15 : C NBCOL : NOMBRE DE COLONNES DE LA GRILLE 16 : C NKCOIN : NKCOIN(I) NOMBRE DE LIGNE ET DE COLONNES 17 : C A ENLEVER AU COIN I 18 : C EN SORTIE : 19 : C IPT3 : LE MAILLAGE QUADRANGULAIRE LINAIRE RESULTANT 20 : C NBE : NOMBRE D'ELEMENTS DU MAILLAGE 21 : C NBN : NOMBRE DE NOEUDS DU MAILLAGE (AVEC NOEUDS MILIEUX) 22 : C IERRDS : CODE D'ERREUR -1 DONNEES INCORRECTE, 0 OK 23 : C 24 : C ********************************************************************** 25 : IMPLICIT INTEGER(I-N) 26 : IMPLICIT REAL*8 (A-H,O-Z) 27 : C 28 : INTEGER IREGIO(4),NBLIG,NBCOL,NKCOIN(4) 29 : INTEGER NBE,NBN,IERRDS 30 : -INC CCOPTIO 31 : -INC SMELEME 32 : SEGMENT ITRAVX 33 : INTEGER ITVL (ITOTAI) 34 : ENDSEGMENT 35 : SEGMENT RTRAVX 36 : REAL*8 RTVL (ITOTAR) 37 : ENDSEGMENT 38 : SEGMENT /FER/(NFI(ITT),MAI(IPP),ITOUR),AFER.FER 39 : * ATTENTION SI XPROJ A 4 COMPOSANTES CE SONT X Y D Z 40 : SEGMENT XPROJ(N,1) 41 : C 42 : C WRITE (6,*) 'ON A LANCER DALL' 43 : C ==================================== 44 : C --- ALLOCATION DES TABLEAUX DE TRAVAIL --- 45 : C ==================================== 46 : ITRACE = 0 47 : IDIMC = XPROJ(/1) 48 : NBNMAX = 4 49 : NBCMAX = NBNMAX 50 : C write (6,*) 'idimc = ',idimc 51 : NBEMAX = (NBLIG-1)*(NBCOL-1) 52 : NBPMAX = NBLIG*NBCOL 53 : NBPOLY = IREGIO(1)+IREGIO(2)+IREGIO(3)+IREGIO(4) 54 : NITMAX = 8*NBEMAX +6*NBPMAX+NBPOLY+1 55 : NRTMAX = IDIMC * NBPMAX 56 : ITOTAI = NITMAX 57 : SEGINI ITRAVX 58 : ITOTAR = NRTMAX 59 : SEGINI RTRAVX 60 : C 61 : C ======================= 62 : C --- TRANSFERT DU POLYGONE --- 63 : C ======================= 64 : C ITVL(IPOLY) = REFERENCE DANS XPROJ 65 : C 66 : C ATTENTION LES NOEUDS MILIEUX SONT MIS AU DEBUT 67 : C 68 : IDEBUT = MAI(1) + 1 69 : C IF( ITOUR .NE.1 )THEN 70 : C WRITE(6,*) 'ATTENTION PLUS D UN CONTOUR ' 71 : C ENDIF 72 : C IF( NBPOLY .NE. (MAI(ITOUR +1)-IDEBUT+1))THEN 73 : C WRITE(6,*) 'NBPOLY = ',NBPOLY 74 : C WRITE(6,*) 'MAI(1),MAI(ITOUR +1)=', 75 : C > MAI(1),MAI(ITOUR +1) 76 : C ENDIF 77 : C 78 : IPOLY = 1 79 : DO 10 I=1,NBPOLY 80 : ITVL(I-1+IPOLY) = I 81 : 10 CONTINUE 82 : ITVL(NBPOLY+IPOLY) = 1 83 : C 84 : ICOORD = 1 85 : DO 30 I=1,NBPOLY 86 : DO 20 J=1,IDIMC 87 : RTVL((I-1)*IDIMC+J-1+ICOORD) = XPROJ(J,I+IDEBUT-1) 88 : 20 CONTINUE 89 : 30 CONTINUE 90 : C 91 : C ===================================== 92 : C --- ALLOCATION DES TABLEAUX DE DONNEES --- 93 : C ===================================== 94 : C 95 : NBE = 0 96 : NBN = 0 97 : ITRNOE = NBPOLY + IPOLY + 1 98 : ITRTRI = NBEMAX*NBNMAX + ITRNOE 99 : NOETRI = NBEMAX*NBCMAX + ITRTRI 100 : NOEMAX = NBPMAX 101 : ITRAV = NBPMAX + NOETRI 102 : ITRVMX = NITMAX-ITRAV+1 103 : C 104 : IF( (NRTMAX-ICOORD+1).LT.(NBPMAX*IDIMC))THEN 105 : IERRDS = -2 105 : CALL ESERRO(1,IERRDS,'DALLOS',' RTVL TROP PETIT') 106 : GOTO 8888 107 : ENDIF 108 : C 109 : IF(ITRVMX.LT.(3*(NBLIG*NBCOL)))THEN 110 : IERRDS = -2 111 : C write(6,*) 'NITMAX =',NITMAX 112 : C write(6,*) 'ITRNOE =',ITRNOE 113 : C write(6,*) 'NBEMAX =',NBEMAX 113 : CALL ESERRO(1,IERRDS,'DALLOS',' ITVL TROP PETIT') 114 : GOTO 8888 115 : ENDIF 116 : C 117 : C 118 : IF(ITRACE.GT.0)THEN 118 : CALL ESECHA(1,'MAILLAGE D UN DOMAINE A 4 COTES',' ') 119 : ENDIF 120 : C 121 : C WRITE(6,*)'POLY =',(ITVL(IPOLY+I-1),I=1,NBPOLY+1) 122 : C WRITE(6,*)'COORD =', 123 : C > ((RTVL((I-1)*IDIMC+J),J=1,IDIMC),I=1,NBPOLY) 124 : C 125 : C ITRACE = 1 126 : C 127 : C ===================================== 128 : C --- APPEL A L'ALGORITHME : BLOCOS --- 129 : C ===================================== 130 : C 131 : ICOMPR = 1 132 : ILISS = 1 133 : W = 0.75 134 : EPSLIS = 0.0 135 : DO 50 I=1,NBPOLY 136 : N1 = ITVL(I-1+IPOLY) 137 : N2 = ITVL(I+IPOLY) 138 : DEPS = 0.0 139 : DO 40 J=1,IDIMC 140 : DEPS = DEPS + (RTVL((N1-1)*IDIMC+J-1+ICOORD) - 141 : > RTVL((N2-1)*IDIMC+J-1+ICOORD))**2 142 : 40 CONTINUE 143 : IF(EPSLIS.EQ.0.0)EPSLIS = DEPS 144 : IF(DEPS.LT.EPSLIS)EPSLIS = DEPS 145 : 50 CONTINUE 146 : EPSLIS = 0.001 * SQRT(EPSLIS) 147 : C WRITE(6,*) 'EPSLIS = ',EPSLIS 148 : C 148 : CALL BLOCOS(ITVL(IPOLY),IREGIO, 149 : > RTVL(ICOORD),IDIMC,NBPOLY, 150 : > NBLIG,NBCOL,NKCOIN, 151 : > ITVL(ITRAV),ITRVMX, 152 : > IDE,ITVL(ITRNOE),NBNMAX,ITVL(ITRTRI), 153 : > NBCMAX,ITVL(NOETRI),NOEMAX, 154 : > NBE,NBN,NBEMAX,NBPMAX, 155 : > ICOMPR,ILISS,EPSLIS,W, 156 : > ITRACE,IERCOD,IERRDS) 157 : C 157 : C CALL Q4CR4C(ITVL(IPOLY),IREGIO, 158 : C > RTVL(ICOORD),IDIMC,NBPOLY, 159 : C > NBLIG,NBCOL,NKCOIN, 160 : C > ITVL(ITRAV),NITMAX, 161 : C > IDE,ITVL(ITRNOE),NBNMAX,NBE,NBN,NBEMAX,NBPMAX, 162 : C > ITRACE,IERRDS) 163 : C 164 : IF(IERRDS.NE.0)THEN 165 : C WRITE(6,*) 'ERREUR DANS BLOCOS : ',IERRDS 166 : GOTO 8888 167 : ENDIF 168 : C 169 : C ===================================== 170 : C --- TRANSFERT DES RESULTATS --- 171 : C ===================================== 172 : C 173 : NBNN = 4 174 : NBREF = 0 175 : NBSOUS = 0 176 : NBELEM = NBE 177 : SEGINI IPT3 178 : C write(6,*) 'IPT3 =',IPT3 179 : C 8 = QUA4, 10 = QUA8 180 : IPT3.ITYPEL = 8 181 : C 182 : DO 100 I=1,NBE 183 : DO 100 J=1,NBNN 184 : IPT3.NUM(J,I) =ITVL((I-1)*NBNMAX+J-1+ITRNOE)+IDEBUT-1 185 : 100 CONTINUE 186 : C WRITE(6,*)'LE MAILLAGE AVANT SORTIE ' 187 : C WRITE(6,*) ((IPT3.NUM(J,I),J=1,NBNN),I=1,NBE) 188 : C WRITE(6,*) ((ITVL((I-1)*NBNMAX+J-1+ITRNOE),J=1,NBNN),I=1,NBE) 189 : C 190 : C 191 : ICOORD = 1 192 : DO 110 I=1,NBN 193 : XPROJ(1,I+IDEBUT-1) = RTVL((I-1)*IDIMC+ICOORD) 194 : XPROJ(2,I+IDEBUT-1) = RTVL((I-1)*IDIMC+1+ICOORD) 195 : C --- IL FAUX REVOIR LE CALCUL DE LA DENSITE --- 196 : XPROJ(3,I+IDEBUT-1) = RTVL((I-1)*IDIMC+2+ICOORD) 197 : IF( XPROJ(/1).EQ.4)THEN 198 : XPROJ(4,I+IDEBUT-1) = RTVL((I-1)*IDIMC+3+ICOORD) 199 : ENDIF 200 : 110 CONTINUE 201 : NBN = NBN + IDEBUT-1 202 : C 203 : 8888 CONTINUE 204 : SEGSUP ITRAVX,RTRAVX 205 : C write(6,*) 'IPT3 =',IPT3 206 : C WRITE(6,*)'LE MAILLAGE AVANT SORTIE ' 207 : C WRITE(6,*) ((IPT3.NUM(J,I),J=1,NBNN),I=1,NBE) 208 : 9999 END 209 : 210 : 211 : 212 :
© Cast3M 2003 - All rights reserved.
Disclaimer