1 : C SURFP4 SOURCE PV 07/11/23 21:19:33 5978 2 : SUBROUTINE SURFP4 (OPERAT,UVARIE,LIGNE1,LIGNE3,msurfp) 3 : ************************************************************************ 4 : * 5 : * S U R F P 4 6 : * ----------- 7 : * 8 : * FONCTION: 9 : * --------- 10 : * 11 : * CREER 2 COTES OPPOSES D'UNE SURFACE PARAMETREE. 12 : * 13 : * MODULES UTILISES: 14 : * ----------------- 15 : * 16 : IMPLICIT REAL*8(A-H,O-Z) 17 : IMPLICIT INTEGER(I-N) 18 : -INC CCOPTIO 19 : -INC CCGEOME 20 : -INC SMCOORD 21 : -INC TMCOURB 22 : -INC TMSURFP 23 : * 24 : * PARAMETRES: (E)=ENTREE (S)=SORTIE (+ = CONTENU DANS UN COMMUN) 25 : * ----------- 26 : * 27 : * OPERAT (E) NOM DE L'OPERATEUR COURANT. 28 : * UVARIE (E) = .TRUE. SI ON S'OCCUPE DES COTES OU LE PARAMETRE 29 : * "U" VARIE (CE QUI EQUIVAUT A "V" CONSTANT). 30 : * = .FALSE. SINON. 31 : * LIGNE1 (S) POINTEUR DE "MAILLAGE". COTE DE LA SURFACE. 32 : * LIGNE3 (S) POINTEUR DE "MAILLAGE". COTE OPPOSE A "LIGNE1". 33 : * +MSURFP (E) POINTEUR DE LA SURFACE PARAMETREE. 34 : * (S) LAISSE DANS L'ETAT ACTIF. 35 : * COMPLETION DU SEGMENT. 36 : * +DENSIT (E) VOIR LE COMMUN "CGEOME". 37 : * +IDIM (E) VOIR LE COMMUN "COPTIO". 38 : * +MCOORD (E) VOIR LE COMMUN "COPTIO". 39 : * (S) LE SEGMENT ASSOCIE EST ETENDU (AVEC LES POINTS 40 : * INTERIEURS DES COTES OPPOSES). 41 : * 42 : CHARACTER*4 OPERAT 43 : LOGICAL UVARIE 44 : INTEGER LIGNE1,LIGNE3 45 : * 46 : * VARIABLES: 47 : * ---------- 48 : * 49 : POINTEUR MCOUR1.MCOURB,MCOFC1.MCOFCO 50 : * 51 : * CONSTANTES: 52 : * ----------- 53 : * 54 : CHARACTER*4 DALL 55 : PARAMETER (DALL = 'DALL') 56 : * 57 : * FONCTIONS: 58 : * ---------- 59 : * 60 : REAL*8 POLYNO 61 : * 62 : * AUTEUR, DATE DE CREATION: 63 : * ------------------------- 64 : * 65 : * PASCAL MANIGOT 6 MARS 1987 66 : * 67 : * LANGAGE: 68 : * -------- 69 : * 70 : * ESOPE + FORTRAN77 + EXTENSION: DECLARATION "REAL*8". 71 : * 72 : ************************************************************************ 73 : * 74 : SEGACT,MCOORD*MOD 75 : SEGACT,MSURFP*MOD 76 : MCOFSU = ICOFSU 77 : MUVSUR = IUVSUR 78 : * 79 : * 80 : * -- CREATION DU COTE N.1 : U DE U1SUR A U2SUR ; V = V1SUR -- 81 : * OU 82 : * -- CREATION DU COTE N.2 : U = U2SUR ; V DE V1SUR A V2SUR -- 83 : * 84 : LONG = 0 85 : SEGINI,MCOURB 86 : * 87 : NLMCOU = 0 88 : D1COU = DENSIT 89 : D2COU = DENSIT 90 : LI1COU = 0 91 : LI2COU = 0 92 : REGCOU = REGSUR 93 : IF (UVARIE) THEN 94 : U1COU = U1SUR 95 : U2COU = U2SUR 96 : PT1COU = PT1SUR 97 : PT2COU = PT2SUR 98 : ND1COU = NCOSUR 99 : ELSE 100 : U1COU = V1SUR 101 : U2COU = V2SUR 102 : PT1COU = PT2SUR 103 : PT2COU = PT3SUR 104 : ND1COU = NLISUR 105 : END IF 106 : * 107 : SEGACT,MCOFSU*MOD 108 : N = ND1COU 109 : SEGINI,MCOFCO 110 : ICOFCO = MCOFCO 111 : IF (UVARIE) THEN 112 : DO 110 IB1=1,IDIM 113 : DO 110 IB2=1,N 114 : COFCOU(IB2,IB1) 115 : & = POLYNO (COFSUR(1,IB2,IB1),NLISUR,1,V1SUR) 116 : 110 CONTINUE 117 : * END DO 118 : * END DO 119 : ELSE 120 : DO 120 IB1=1,IDIM 121 : DO 120 IB2=1,N 122 : COFCOU(IB2,IB1) 123 : & = POLYNO (COFSUR(IB2,1,IB1),NCOSUR,NLISUR,U2SUR) 124 : 120 CONTINUE 125 : * END DO 126 : * END DO 127 : END IF 128 : SEGDES,MCOFSU 129 : * 129 : CALL COURB2 (MCOURB, LIGNE1) 130 : IF (IERR .NE. 0) RETURN 131 : SEGDES,MCOURB 132 : * 133 : * -- CREATION DU COTE N.3 : U DE U2SUR A U1SUR ; V = V2SUR -- 134 : * OU 135 : * -- CREATION DU COTE N.4 : U = U1SUR ; V DE V2SUR A V1SUR -- 136 : * 137 : LONG = 0 138 : SEGINI,MCOUR1 139 : * 140 : MCOUR1.NLMCOU = 0 141 : MCOUR1.D1COU = DENSIT 142 : MCOUR1.D2COU = DENSIT 143 : MCOUR1.LI1COU = 0 144 : MCOUR1.LI2COU = 0 145 : MCOUR1.REGCOU = REGSUR 146 : IF (UVARIE) THEN 147 : MCOUR1.U1COU = U2SUR 148 : MCOUR1.U2COU = U1SUR 149 : MCOUR1.PT1COU = PT3SUR 150 : MCOUR1.PT2COU = PT4SUR 151 : MCOUR1.ND1COU = NCOSUR 152 : ELSE 153 : MCOUR1.U1COU = V2SUR 154 : MCOUR1.U2COU = V1SUR 155 : MCOUR1.PT1COU = PT4SUR 156 : MCOUR1.PT2COU = PT1SUR 157 : MCOUR1.ND1COU = NLISUR 158 : END IF 159 : * 160 : SEGACT,MCOFSU*MOD 161 : N = MCOUR1.ND1COU 162 : SEGINI,MCOFC1 163 : MCOUR1.ICOFCO = MCOFC1 164 : IF (UVARIE) THEN 165 : DO 130 IB1=1,IDIM 166 : DO 130 IB2=1,N 167 : MCOFC1.COFCOU(IB2,IB1) 168 : & = POLYNO (COFSUR(1,IB2,IB1),NLISUR,1,V2SUR) 169 : 130 CONTINUE 170 : * END DO 171 : * END DO 172 : ELSE 173 : DO 140 IB1=1,IDIM 174 : DO 140 IB2=1,N 175 : MCOFC1.COFCOU(IB2,IB1) 176 : & = POLYNO (COFSUR(IB2,1,IB1),NCOSUR,NLISUR,U1SUR) 177 : 140 CONTINUE 178 : * END DO 179 : * END DO 180 : END IF 181 : SEGDES,MCOFSU 182 : * 182 : CALL COURB2 (MCOUR1, LIGNE3) 183 : IF (IERR .NE. 0) RETURN 184 : SEGDES,MCOUR1 185 : * 186 : IF (OPERAT .EQ. DALL) THEN 187 : * LES COTES OPPOSES DOIVENT AVOIR MEME NOMBRE D'ELEMENTS DANS LE 188 : * CAS D'UN DALLAGE. 189 : * 190 : SEGACT,MCOURB*MOD,MCOUR1*MOD 191 : NLM = NLMCOU 192 : NL1 = MCOUR1.NLMCOU 193 : IF (NLM .NE. NL1) THEN 194 : IF (NL1.EQ.(NLM-1) .OR. NL1.EQ.(NLM+1) ) THEN 195 : SEGDES,MCOURB 195 : CALL COURB9 (MCOUR1,LIGNE3) 196 : SEGACT,MCOUR1*MOD 197 : MCOUR1.NLMCOU = NLM 197 : CALL COURB2 (MCOUR1,LIGNE3) 198 : IF (IERR .NE. 0) RETURN 199 : SEGDES,MCOUR1 200 : ELSE 201 : * APPELS "COURB9" EN SENS INVERSE DE L'ORDRE DE CREATION: 201 : CALL COURB9 (MCOUR1,LIGNE3) 201 : CALL COURB9 (MCOURB,LIGNE1) 202 : NLM = (NLM + NL1) / 2 203 : SEGACT,MCOURB*MOD 204 : NLMCOU = NLM 204 : CALL COURB2 (MCOURB,LIGNE1) 205 : IF (IERR .NE. 0) RETURN 206 : SEGDES,MCOURB 207 : SEGACT,MCOUR1*MOD 208 : MCOUR1.NLMCOU = NLM 208 : CALL COURB2 (MCOUR1,LIGNE3) 209 : IF (IERR .NE. 0) RETURN 210 : SEGDES,MCOUR1 211 : END IF 212 : ELSE 213 : SEGDES,MCOURB,MCOUR1 214 : END IF 215 : END IF 216 : * 217 : SEGSUP,MCOFCO,MCOFC1 218 : * 219 : * REMPLISSAGE DE LA TABLE DES COORDONNEES PARAMETRIQUES DU CONTOUR: 220 : * 221 : SEGACT,MUVSUR*MOD 222 : SEGACT,MCOURB*MOD,MCOUR1*MOD 223 : LONG0 = USUR(/1) 224 : LONG1 = UCOU(/1) 225 : LONG3 = MCOUR1.UCOU(/1) 226 : LONG = LONG0 + LONG1 + LONG3 227 : SEGADJ,MUVSUR 228 : * 229 : IF (UVARIE) THEN 230 : DO 210 IB=(LONG0+1),(LONG0+LONG1) 231 : USUR(IB) = UCOU(IB-LONG0) 232 : VSUR(IB) = V1SUR 233 : 210 CONTINUE 234 : * END DO 235 : LONG01 = LONG0 + LONG1 236 : DO 230 IB=(LONG01+1),LONG 237 : USUR(IB) = MCOUR1.UCOU(IB-LONG01) 238 : VSUR(IB) = V2SUR 239 : 230 CONTINUE 240 : * END DO 241 : ELSE 242 : DO 220 IB=(LONG0+1),(LONG0+LONG1) 243 : VSUR(IB) = UCOU(IB-LONG0) 244 : USUR(IB) = U2SUR 245 : 220 CONTINUE 246 : * END DO 247 : LONG01 = LONG0 + LONG1 248 : DO 240 IB=(LONG01+1),LONG 249 : VSUR(IB) = MCOUR1.UCOU(IB-LONG01) 250 : USUR(IB) = U1SUR 251 : 240 CONTINUE 252 : * END DO 253 : END IF 254 : * 255 : SEGDES,MUVSUR 256 : SEGSUP,MCOURB,MCOUR1 257 : * 258 : END 259 : 260 : 261 : 262 : 263 : 264 : 265 : 266 : 267 : 268 :
© Cast3M 2003 - All rights reserved.
Disclaimer