1 : C COURB1 SOURCE PV 11/03/07 21:16:10 6885 2 : SUBROUTINE COURB1 (MCOURB,LIGNE) 3 : implicit real*8 (a-h,o-z) 4 : ************************************************************************ 5 : * 6 : * C O U R B 1 7 : * ----------- 8 : * 9 : * FONCTION: 10 : * --------- 11 : * 12 : * EXECUTE LA TACHE DE L'OPERATEUR "COURBE". 13 : * 14 : * MODULES UTILISES: 15 : * ----------------- 16 : * 17 : IMPLICIT INTEGER(I-N) 18 : -INC CCOPTIO 19 : -INC CCGEOME 20 : -INC SMCOORD 21 : -INC SMELEME 22 : -INC TMCOURB 23 : * 24 : * PARAMETRES: (E)=ENTREE (S)=SORTIE (+ = CONTENU DANS UN COMMUN) 25 : * ----------- 26 : * 27 : * MCOURB (E) SEGMENT ACTIF. 28 : * +DENSIT (E) VOIR LE COMMUN "CGEOME". 29 : * +IDIM (E) VOIR LE COMMUN "COPTIO". 30 : * +MCOORD (E) VOIR LE COMMUN "COPTIO". 31 : * LIGNE (S) OBJET 'MAILLAGE' CREE. 32 : * 33 : * VARIABLES: 34 : * ---------- 35 : * 36 : * NOXTRM = .TRUE. SI AUCUN POINT-EXTREMITE CONVENABLE N'A ETE 37 : * FOURNI (UTILISE DANS LA PROCEDURE INTERNE, A LA FIN). 38 : * DIST = DISTANCE ENTRE POINT FOURNI POUR EXTREMITE ET VERITABLE 39 : * POINT EXTREME DE LA COURBE. 40 : * X1COU, ) 41 : * X2COU, ) COORDONNEES DES POINTS EXTREMITES DE LA COURBE. 42 : * Y1COU, ) 43 : * ETC... ) 44 : * 45 : INTEGER PT0COU,LI0COU 46 : LOGICAL NOXTRM,ltelq 47 : REAL*8 X1COU,Y1COU,Z1COU,X2COU,Y2COU,Z2COU 48 : REAL*8 X0COU,Y0COU,Z0COU,D0COU 49 : * 50 : * FONCTIONS: 51 : * ---------- 52 : * 53 : REAL*8 POLYNO 54 : * 55 : * AUTEUR, DATE DE CREATION: 56 : * ------------------------- 57 : * 58 : * PASCAL MANIGOT 10 SEPTEMBRE 1986 59 : * P.M. 24/02/87 : REMODELAGE, AVEC UN NOUVEAU SEGMENT "MCOURB". 60 : * 61 : * LANGAGE: 62 : * ------ 63 : * 64 : * ESOPE + FORTRAN77 + EXTENSION: DECLARATION "REAL*8". 65 : * 66 : ************************************************************************ 67 : * 68 : SEGACT,MCOORD 69 : * 70 : * RECHERCHE DES POINTS EXTREMES EN CAS DE DONNEE DE COURBES A 71 : * RACCORDER: 72 : * 73 : IF (LI1COU .NE. 0) THEN 74 : * ON RELEVE LE DERNIER POINT DE LA LIGNE A RACCORDER EN TETE DE 75 : * LA COURBE: 76 : N = 1 77 : * (CURIEUSEMENT, C'EST LA VALEUR "1" QUI PERMET D'EXTRAIRE LE 78 : * DERNIER POINT) 79 : LI0COU = LI1COU 80 : IPT6=LI0COU 81 : SEGACT IPT6 81 : CALL EXTRPO (LI0COU,N, PT0COU) 82 : IF (IERR .NE. 0) RETURN 83 : PT1COU = PT0COU 84 : END IF 85 : * 86 : IF (LI2COU .NE. 0) THEN 87 : * ON RELEVE LE 1ER POINT DE LA LIGNE A RACCORDER A LA FIN DE LA 88 : * COURBE: 89 : N = 2 90 : LI0COU = LI2COU 91 : IPT6=LI0COU 92 : SEGACT IPT6 92 : CALL EXTRPO (LI0COU,N, PT0COU) 93 : IF (IERR .NE. 0) RETURN 94 : PT2COU = PT0COU 95 : END IF 96 : * 97 : * CALCUL DES COORDONNEES DES POINTS EXTREMES. 98 : * 99 : MCOFCO = ICOFCO 100 : SEGACT,MCOFCO 101 : X1COU = POLYNO (COFCOU(1,1),ND1COU,1,U1COU) 102 : X2COU = POLYNO (COFCOU(1,1),ND1COU,1,U2COU) 103 : Y1COU = POLYNO (COFCOU(1,2),ND1COU,1,U1COU) 104 : Y2COU = POLYNO (COFCOU(1,2),ND1COU,1,U2COU) 105 : IF (IDIM .EQ. 3) THEN 106 : Z1COU = POLYNO (COFCOU(1,3),ND1COU,1,U1COU) 107 : Z2COU = POLYNO (COFCOU(1,3),ND1COU,1,U2COU) 108 : END IF 109 : SEGDES,MCOFCO 110 : * 111 : * LES POINTS EXTREMES FOURNIS EXPLICITEMENT (LE CAS ECHEANT) 112 : * SONT-ILS ACCEPTABLES ? 113 : * (SINON, CREATION DE NOUVEAUX) 114 : * 115 : * APPEL PROCEDURE INTERNE: 116 : PT0COU = PT1COU 117 : X0COU = X1COU 118 : Y0COU = Y1COU 119 : IF (IDIM .EQ. 3) Z0COU = Z1COU 120 : D0COU = D1COU 121 : ASSIGN 105 TO IRTURN 122 : GOTO 500 123 : 105 CONTINUE 124 : * RETOUR DE PROCEDURE INTERNE. 125 : IF (PT1COU .NE. 0 .AND. PT1COU .NE. PT0COU) THEN 126 : IF (LI1COU .EQ. 0) THEN 126 : CALL ERREUR (295) 127 : ELSE 127 : CALL ERREUR (297) 128 : END IF 129 : * IL N'Y A PAS LIEU DE S'ARRETER POUR SI PEU. 130 : END IF 131 : PT1COU = PT0COU 132 : D1COU = D0COU 133 : * 134 : * APPEL PROCEDURE INTERNE: 135 : PT0COU = PT2COU 136 : X0COU = X2COU 137 : Y0COU = Y2COU 138 : IF (IDIM .EQ. 3) Z0COU = Z2COU 139 : D0COU = D2COU 140 : ASSIGN 205 TO IRTURN 141 : GOTO 500 142 : 205 CONTINUE 143 : * RETOUR DE PROCEDURE INTERNE. 144 : IF (PT2COU .NE. 0 .AND. PT2COU .NE. PT0COU) THEN 145 : IF (LI2COU .EQ. 0) THEN 145 : CALL ERREUR (296) 146 : ELSE 146 : CALL ERREUR (298) 147 : END IF 148 : * IL N'Y A PAS LIEU DE S'ARRETER POUR SI PEU. 149 : END IF 150 : PT2COU = PT0COU 151 : D2COU = D0COU 152 : * 153 : * LES EXTREMITES ETANT MAINTENANT BIEN DEFINIES, ON APPELLE LE 154 : * SOUS-PROGRAMME DE MAILLAGE. 155 : * 155 : CALL COURB2 (MCOURB, LIGNE) 156 : IF (IERR .NE. 0) RETURN 157 : * 158 : * SI DES LIGNES ONT ETE DONNEES AU LIEU DE POINTS EXTREMES, 159 : * L'OBJET RESULTAT N'EST PAS CE QUI VIENT D'ETRE CREE MAIS LA 160 : * REUNION DES ANCIENNES LIGNES ET DE CE QUI VIENT D'ETRE CREE: 161 : * 162 : IF (LI1COU .NE. 0) THEN 163 : LI0COU = LI1COU 164 : ltelq=.false. 164 : CALL FUSE (LI0COU,LIGNE, IP,ltelq) 165 : IF (IERR .NE. 0) RETURN 166 : LIGNE = IP 167 : END IF 168 : IF (LI2COU .NE. 0) THEN 169 : LI0COU = LI2COU 170 : ltelq=.false. 170 : CALL FUSE (LIGNE,LI0COU, IP,ltelq) 171 : IF (IERR .NE. 0) RETURN 172 : LIGNE = IP 173 : END IF 174 : * 175 : IF (IIMPI .EQ. 342) THEN 176 : IDIMP1 = IDIM + 1 177 : DO 400 IB=1,XCOOR(/1),IDIMP1 178 : IB2 = IB / IDIMP1 + 1 179 : WRITE (IOIMP,'(1X,I5,3(1X,G12.5))') IB2,XCOOR(IB) 180 : & ,XCOOR(IB+1),XCOOR(IB+IDIM) 181 : 400 CONTINUE 182 : * END DO 183 : END IF 184 : * 185 : RETURN 186 : * 187 : * *********************** 188 : * * PROCEDURE INTERNE * 189 : * *********************** 190 : * 191 : * PARAMETRES: 192 : * 193 : * PT0COU (E) POINT EXTREME PROPOSE. 194 : * (S) POINT EXTREME FINALEMENT RETENU. 195 : * X0COU (E) ) 196 : * Y0COU (E) )) COORDONNEES DU VERITABLE POINT EXTREME. 197 : * Z0COU (E) ) 198 : * D0COU E/S DENSITE ASSOCIEE (LARGEUR DE MAILLE). 199 : * MCOORD (E) SEGMENT ACTIF. 200 : * (S) CE SEGMENT EST EVENTUELLEMENT ETENDU. 201 : * 202 : 500 CONTINUE 203 : * 204 : IF (PT0COU .NE. 0) THEN 205 : IPD = (PT0COU - 1) * (IDIM + 1) 206 : X0DONN = XCOOR(IPD+1) 207 : Y0DONN = XCOOR(IPD+2) 208 : IF (IDIM .EQ. 3) THEN 209 : Z0DONN = XCOOR(IPD+3) 210 : DIST = SQRT((X0COU-X0DONN)**2 + (Y0COU-Y0DONN)**2 211 : & + (Z0COU-Z0DONN)**2) 212 : ELSE 213 : DIST = SQRT((X0COU-X0DONN)**2 + (Y0COU-Y0DONN)**2) 214 : END IF 215 : IF (D0COU .EQ. 0.) THEN 216 : IPD = PT0COU * (IDIM + 1) 217 : D0DONN = XCOOR(IPD) 218 : PETIT = D0DONN * 0.1 219 : ELSE 220 : PETIT = D0COU * 0.1 221 : END IF 222 : NOXTRM = DIST.GT.PETIT 223 : ELSE 224 : NOXTRM = .TRUE. 225 : END IF 226 : * 227 : IF (NOXTRM) THEN 228 : * UN POINT EXTREME NON ACCEPTABLE A ETE FOURNI OU BIEN AUCUN 229 : * POINT N'A ETE FOURNI. 230 : * CREATION D'UN NOUVEAU POINT POUR L'EXTREMITE: 231 : IF (D0COU .EQ. 0.) THEN 232 : D0COU = DENSIT 233 : END IF 233 : CALL CREPO2 (X0COU,Y0COU,Z0COU,D0COU, PT0COU) 234 : IF (IERR .NE. 0) RETURN 235 : ELSE IF (D0COU .EQ. 0.) THEN 236 : * POINT IMPOSE CORRECT ET PAS DE DENSITE IMPOSEE 237 : * --> ON PREND CELLE DU POINT IMPOSE: 238 : D0COU = D0DONN 239 : * ELSE 240 : * SI POINT IMPOSE CORRECT ET DENSITE FOURNIE, RIEN A FAIRE. 241 : END IF 242 : * 243 : GOTO IRTURN 244 : * 245 : END 246 : 247 : 248 : 249 : 250 : 251 : 252 : 253 : 254 : 255 :
© Cast3M 2003 - All rights reserved.
Disclaimer