Esope source files

   1 : C CHASUP    SOURCE    FANDEUR   13/02/07    21:15:06     7694           
   2 :       SUBROUTINE CHASUP(IPMODL,IPOI1,IPOI2,IRET,IPLAC)
   3 : C---------------------------------------------------------------------
   4 : 
   5 : C     ENTREES:
   6 : C
   7 : C       IPMODL     Pointeur sur un MMODEL
   8 : C       IPOI1      Pointeur sur un MCHAML
   9 : C       IPLAC      Indique le type de support demandé :
  10 : C               1  scalaire aux NOEUDS
  11 : C               2  scalaire au  CENTRE DE GRAVITE
  12 : C               3  scalaire aux points d'integration de la RAIDEUR
  13 : C               4  scalaire aux points d'integration de la MASSE
  14 : C               5  scalaire aux points de CONTRAINTES
  15 : C
  16 : C      AM  14/6/07  SI IPLAC EST NEGATIF, ON RECUPERE UN CHAMP QUI
  17 : C                   NE CONTIENT PAS LES COMPOSANTES COMPLEXES (NON SCALAIRES)
  18 : C                   QU'ON A N'A PAS PU CHANGER
  19 : C                   SINON, ON SORT EN ERREUR
  20 : C
  21 : C     SORTIE:
  22 : C
  23 : C       IPOI2      Pointeur sur un MCHAML
  24 : C       IRET      =0 Si tout est ok
  25 : C                    Sinon contient le numero d'erreur
  26 : C
  27 : C     I.MONNIER le 31.05.90
  28 : C
  29 : C---------------------------------------------------------------------
  30 :       IMPLICIT INTEGER(I-N)
  31 :       IMPLICIT REAL*8(A-H,O-Z)
  32 : -INC CCOPTIO
  33 : -INC SMMODEL
  34 : -INC SMCHAML
  35 : -INC SMELEME
  36 : -INC SMINTE
  37 : -INC SMCOORD
  38 :       CHARACTER*8 CHARIN,CHARTY
  39 : C
  40 :       SEGMENT SWORK
  41 :         REAL*8 VAL1(NBPGA1),VAL2(NBPGAU),VALN(NBNN)
  42 :         REAL*8 SHP(6,NBNN) ,XE(3,NBNN)
  43 :       ENDSEGMENT
  44 : C
  45 :       SEGMENT SWORK2
  46 :         INTEGER LETAB(N22)
  47 :       ENDSEGMENT
  48 : *
  49 : *     NBPGA1,NBPGAU DESIGNENT LES TAILLES MAX DES CHAMPS CH1 ET CH2
  50 : *     N1PTE1,N1PTEL DESIGNENT LES TAILLES EFFECTIVES DE CES CHAMPS
  51 : *
  52 :       SEGMENT  INFO
  53 :         INTEGER INFELL(JG)
  54 :       ENDSEGMENT
  55 : C
  56 :       IRET=0
  57 : C
  58 : C     ACTIVATION DU MODELE
  59 : C
  60 :       MMODEL=IPMODL
  61 :       SEGACT MMODEL
  62 :       NSOUS1=KMODEL(/1)
  63 : C
  64 : C     ACTIVATION DES MCHELM
  65 : C
  66 :       MCHEL1 =IPOI1
  67 :       SEGACT MCHEL1
  68 :       NSOUS=MCHEL1.ICHAML(/1)
  69 :       IF(NSOUS.GT.NSOUS1)THEN
  70 : *  on va essayer de reduir le champ
  70 :       call reduaf(mchel1,mmodel,mchel10,0,ire,kerre)
  71 : **     if (ire.ne.1) then
  71 : **       call erreur(kerre)
  72 : **       IRET=553
  73 : **       SEGDES MMODEL,MCHEL1
  74 : **       RETURN
  75 : **     endif
  76 :        if (ire.eq.1)  mchel1=mchel10
  77 :        SEGACT MCHEL1,mmodel
  78 :        NSOUS=MCHEL1.ICHAML(/1)
  79 :       ENDIF
  80 :       N1=NSOUS
  81 :       L1=MCHEL1.TITCHE(/1)
  82 :       N3=MCHEL1.INFCHE(/2)
  83 :       NINF=N3
  84 :       IF (N3.LT.6) N3=6
  85 :       SEGINI MCHELM
  86 :       TITCHE=MCHEL1.TITCHE
  87 :       IFOCHE=IFOUR
  88 :       IPOI2=MCHELM
  89 :       iresu=0
  90 : C
  91 : C  ON BOUCLE SUR LES SOUS-ZONES DU MCHAML
  92 : C
  93 :       DO 100 ISOUS=1,NSOUS
  94 : *
  95 :         IMACHE(ISOUS)=MCHEL1.IMACHE(ISOUS)
  96 :         CONCHE(ISOUS)=MCHEL1.CONCHE(ISOUS)
  97 :         DO 191 IP=1,NINF
  98 :           INFCHE(ISOUS,IP)=MCHEL1.INFCHE(ISOUS,IP)
  99 :  191    CONTINUE
 100 : C
 101 : C       MISE EN CONCORDANCE DES POINTEURS DE MAILLAGE
 102 : C
 103 :         MELEME=IMACHE(ISOUS)
 104 :         INS=0
 105 :         DO 151 IO=1,NSOUS1
 106 :           IMODEL=KMODEL(IO)
 107 :           SEGACT IMODEL
 107 :         CALL PLACE(FORMOD,FORMOD(/2),IDARC,'DARCY')
 108 :         IPMAIL=IMAMOD
 109 : C
 110 : C      CAS DE LA FORMULATION DARCY ON VA EXTRAIRE LE MAILLAGE SOMMET
 111 :         IF(IDARC.NE.0)THEN
 111 :            CALL LEKMOD(MMODEL,IPTABL,INEFMD)
 112 :            CHARIN = 'MAILLAGE'
 112 :            CALL LEKTAB(IPTABL,CHARIN, IOBRE)
 113 :            IF (IERR.NE.0) RETURN
 114 :            IPT1 = IOBRE
 115 :            IPMAIL= IOBRE
 116 :            segact ipt1
 117 :            IF(N1.GT.1.and.ipt1.lisous(/1).ge.n1)THEN
 118 :            SEGACT IPT1
 119 :            IPMAIL= IPT1.LISOUS(ISOUS)
 120 :            SEGDES IPT1
 121 :            ENDIF
 122 :         ENDIF
 123 :           IF (IPMAIL.EQ.MELEME) INS=INS+1
 124 :  151    CONTINUE
 125 :         DO 150 IO=1,NSOUS1
 126 :           IMODEL=KMODEL(IO)
 127 :           SEGACT IMODEL
 127 :         CALL PLACE(FORMOD,FORMOD(/2),IDARC,'DARCY')
 128 :         IPMAIL=IMAMOD
 129 : C
 130 : C      CAS DE LA FORMULATION DARCY ON VA EXTRAIRE LE MAILLAGE SOMMET
 131 :         IF(IDARC.NE.0)THEN
 131 :            CALL LEKMOD(MMODEL,IPTABL,INEFMD)
 132 :            CHARIN = 'MAILLAGE'
 132 :            CALL LEKTAB(IPTABL,CHARIN, IOBRE)
 133 :            IF (IERR.NE.0) RETURN
 134 :            IPT1 = IOBRE
 135 :            IPMAIL= IOBRE
 136 :            SEGACT IPT1
 137 :            IF(N1.GT.1.and.ipt1.lisous(/1).ge.n1)THEN
 138 :            IPMAIL= IPT1.LISOUS(ISOUS)
 139 :            SEGDES IPT1
 140 :            ENDIF
 141 :         ENDIF
 142 :           IF (IPMAIL.EQ.MELEME.AND.(INS.GE.1.OR.
 143 :      >      CONCHE(ISOUS).EQ.CONMOD)) GOTO 160
 144 :           SEGDES IMODEL
 145 :  150    CONTINUE
 146 : *
 147 :         IRET=472
 148 :         SEGDES,MCHEL1,MMODEL
 149 :         SEGSUP MCHELM
 150 :         RETURN
 151 : *
 152 :  160    MELE=NEFMOD
 153 : 
 154 : **       write(6,*) 'mele ',mele
 155 : *  on saute si element sans les supports
 156 :         if(mele.eq.22) go to 100
 157 :         if(mele.eq.107) go to 100
 158 :         if(mele.eq.165) go to 100
 159 :         if(mele.eq.261) go to 100
 160 : 
 161 : *        write(6,*) 'chasup MCHEL1.INFCHE(ISOUS,4)',
 162 : *     $       MCHEL1.INFCHE(ISOUS,4)
 163 : *        write(6,*) ' chzsup MCHEL1.INFCHE(ISOUS,6) ninf ',
 164 : *     $ MCHEL1.INFCHE(ISOUS,6),ninf
 165 : *
 166 : *      DANS LE CAS DES COQUES INTEGREES ON SORT EN ERREUR
 167 : *
 168 :         IF (NINF.LT.4.OR.MCHEL1.INFCHE(ISOUS,4).EQ.0) THEN
 169 :            MINTE1=0
 170 :            IPLACA=0
 171 :         ELSE
 172 :            MINTE1=MCHEL1.INFCHE(ISOUS,4)
 173 :            IPLACA=MCHEL1.INFCHE(ISOUS,6)
 174 :         ENDIF
 175 : *        write(6,*) 'chasup minte1 ninf', ninf,minte1
 176 : C
 177 :         if (formod(1).eq.'LIAISON') then
 178 :           IPLAC1 = 1
 179 :         else
 180 :           IPLAC1 = ABS(IPLAC)
 181 : C le modele contient t il de la thermique ?
 182 : C s'il y a de la thermique le segment d'integration est particulier
 183 :           IF ( FORMOD(1) .EQ. 'THERMIQUE' ) THEN
 184 :             nmat = matmod(/2)
 185 :             icov = 0
 185 : C*          CALL PLACE(matmod,nmat,icov,'CONVECTION')
 185 :             CALL PLACE(matmod,nmat,iray,'RAYONNEMENT')
 186 :             IF (icov+iray.EQ.0) THEN
 187 :               IF ( IPLAC1 .NE. 1 ) IPLAC1 = 6
 188 :             ENDIF
 189 :           ENDIF
 190 :         endif
 191 : C
 192 :         IF(IPLAC1.EQ.6)THEN
 192 :           CALL TSHAPE(MELE,'GAUSS',IPMINT)
 193 :           IF ( IERR .NE. 0) GOTO 665
 194 :           MINTE=IPMINT
 195 :           MELGEO=NUMGEO(MELE)
 196 :         ELSE
 197 :           if(2+iplac1.gt.infmod(/1))then
 197 :              CALL ELQUOI(MELE,0,IPLAC1,IPTR2,IMODEL)
 198 :                   IF ( IERR .NE. 0) GOTO 665
 199 :              INFO=IPTR2
 200 :             MINTE=INFELL(11)
 201 :             MELGEO=INFELL(14)
 202 :              SEGSUP,INFO
 203 :           else                
 204 :             minte=infmod(2+iplac1)
 205 :             MELGEO=INFELE(14)
 206 :           endif
 207 : *          write(6,*) ' apres zelquoi minte' , minte
 208 :         ENDIF
 209 :         INFCHE(ISOUS,4)=MINTE
 210 :         IF(IPLAC1.EQ.1)INFCHE(ISOUS,4)=0
 211 :         INFCHE(ISOUS,6)=IPLAC1
 212 : C
 213 : C     ON RECUPERE LE NOMBRE D ELEMENTS
 214 : C
 215 :         SEGACT MELEME
 216 :         NBNN  =NUM(/1)
 217 :         NBELEM=NUM(/2)
 218 : C
 219 : C     ON RECUPERE LE NOMBRE DE POINTS SUPPORT
 220 : C     NBPGA1 POUR L'ANCIEN CHAMP ET NBPGAU POUR LE NOUVEAU
 221 : C
 222 :         IF(MINTE1.NE.0)THEN
 223 :           SEGACT MINTE1
 224 :           NBPGA1 = MINTE1.SHPTOT(/3)
 225 :         ELSE
 226 :           NBPGA1=NBNN
 227 :         ENDIF
 228 :         if (minte.eq.0) then
 228 :            call erreur(5)
 229 :            return
 230 :         endif
 231 :         SEGACT MINTE
 232 :         NBPGAU = SHPTOT(/3)
 233 :         nbpga1=max(nbpga1,nbpgau)
 234 : *         write(6,*) ' nbpgau,nbpga1',nbpgau,nbpga1
 235 : C
 236 :         NEL   =NBELEM
 237 :         SEGINI SWORK
 238 : C
 239 : C       PREPARATION POUR CREATION DU MCHAML
 240 : C
 241 :         MCHAM1=MCHEL1.ICHAML(ISOUS)
 242 :         SEGACT MCHAM1
 243 : C
 244 :         N22 = MCHAM1.NOMCHE(/2)
 245 : *       
 246 : *     SI IPLAC < 0, ON CHERCHE LE NOMBRE DE COMPOSANTES A CONSERVER 
 247 : *
 248 :         SEGINI SWORK2
 249 : *
 250 :         IF(IPLAC.GE.0) THEN
 251 :           N2 = N22
 252 :           DO ICOMP=1,N22
 253 :              LETAB(ICOMP) = ICOMP
 254 :           ENDDO
 255 : *
 256 :         ELSE 
 257 : *
 258 : *         BOUCLE SUR LES COMPOSANTES
 259 : *
 260 :           JECO = 0
 261 :           DO 170 ICOMP=1,N22
 262 : C
 263 :             CHARTY=MCHAM1.TYPCHE(ICOMP)
 264 :             MELVA1=MCHAM1.IELVAL(ICOMP)
 265 :             SEGACT MELVA1
 266 :             LETAB(ICOMP) = 0
 267 : *
 268 :             IF(CHARTY(1:6).EQ.'REAL*8') THEN
 269 :               JECO = JECO + 1
 270 :               LETAB(ICOMP) = JECO
 271 :             ENDIF
 272 : *
 273 : *            cas de variables complexes 
 274 : *
 275 :             IF(CHARTY(1:8).EQ.'POINTEUR') THEN
 276 :               N2PTE1=MELVA1.IELCHE(/1)
 277 : *
 278 : * ... Comme on ne sait pas extrapoler ou interpoler de variables
 279 : *     composées, on n'en accepte qu'une par élément ...
 280 : 
 281 :               IF(N2PTE1.EQ.1) THEN
 282 :                 JECO = JECO + 1
 283 :                 LETAB(ICOMP) = JECO
 284 :               ENDIF
 285 :             ENDIF
 286 :           SEGDES MELVA1
 287 :  170    CONTINUE
 288 :         N2 = JECO
 289 : *
 290 :         ENDIF
 291 : *
 292 : *    CREATION DU MCHAML 
 293 : *
 294 :         SEGINI MCHAML
 295 :         iresu=iresu+1
 296 :         ICHAML(iresu)=MCHAML
 297 : C
 298 : C       BOUCLE SUR LES COMPOSANTES EN ENTREE
 299 : C
 300 :         DO 180 ICOMP=1,N22
 301 : C         
 302 :           JCOMP = LETAB(ICOMP)
 303 :           IF(JCOMP.EQ.0) GO TO 180
 304 : 
 305 :           NOMCHE(JCOMP)=MCHAM1.NOMCHE(ICOMP)
 306 :           TYPCHE(JCOMP)=MCHAM1.TYPCHE(ICOMP)
 307 : C
 308 :           MELVA1=MCHAM1.IELVAL(ICOMP)
 309 : *         write (6,*) ' dans chasup melva1 ',melva1
 310 :           SEGACT MELVA1
 311 : *
 312 : *  RECHERCHE DES TAILLES DU NOUVEAU CHAMELEM - dans le cas scalaire
 313 : *
 314 :           IF(TYPCHE(JCOMP)(1:6).EQ.'REAL*8') THEN
 315 :             N1PTE1=MELVA1.VELCHE(/1)
 316 :             IF (N1PTE1.EQ.1) THEN
 317 :               N1PTEL=1
 318 :             ELSE
 319 :               N1PTEL=NBPGAU
 320 :             ENDIF
 321 :             N1EL  =MELVA1.VELCHE(/2)
 322 : *
 323 : *  PETIT TEST DE COMPATIBILITE DES NOMBRES D'ELEMENTS
 324 : *
 325 :             IF(N1EL.NE.NEL.AND.N1EL.NE.1.AND.NEL.NE.1) THEN
 326 :               SEGDES MELVA1,MELEME,IMODEL,MCHAM1
 327 :               SEGSUP SWORK,SWORK2,MCHAML
 328 :               IRET=146
 329 :               MOTERR(1:8)='CHASUP  '
 330 :               GO TO 665
 331 :             ENDIF
 332 : *
 333 :             N1PAUX=N1PTE1
 334 : C
 335 : C-----------------------------------------------------------------------
 336 : C                     PETIT TEST POUR LE COQ4
 337 : C       SI LE NOMBRE DE POINTS DE GAUSS VAUT 5 , ON NE PREND QUE
 338 : C       LES 4 PREMIERS , LE 5-EME SERVANT UNIQUEMENT AU CISAILLEMENT
 339 : C
 340 :             IF (MELE.EQ.49.AND.N1PAUX.EQ.5) N1PAUX=4
 341 : C-----------------------------------------------------------------------
 342 : C
 343 :           ELSE
 344 :              N1PTEL=0
 345 :              N1EL=0
 346 :           ENDIF
 347 : *
 348 : *     ... Et dans le cas de variables complexes ...
 349 : *
 350 :           IF(TYPCHE(JCOMP)(1:8).EQ.'POINTEUR') THEN
 351 :             N2PTE1=MELVA1.IELCHE(/1)
 352 :             IF (N2PTE1.EQ.1) THEN
 353 :               N2PTEL=1
 354 :             ELSE
 355 :               N2PTEL=NBPGAU
 356 :             ENDIF
 357 :             N2EL  =MELVA1.IELCHE(/2)
 358 : *
 359 : * ... Comme on ne sait pas extrapoler ou interpoler de variables
 360 : *     composées, on n'en accepte qu'une par élément ...
 361 : 
 362 : *           IF(N2PTEL.NE.1) THEN
 363 : *             SEGDES MELVA1,MELEME,IMODEL,MCHAM1
 364 : *             SEGSUP SWORK,SWORK2,MCHAML
 365 : *             IRET=755
 366 : *             GO TO 665
 367 : *           ENDIF
 368 : *
 369 : *  PETIT TEST DE COMPATIBILITE DES NOMBRES D'ELEMENTS
 370 : *
 371 :             IF(N2EL.NE.NEL.AND.N2EL.NE.1.AND.NEL.NE.1) THEN
 372 :               SEGDES MELVA1,MELEME,IMODEL,MCHAM1
 373 :               SEGSUP SWORK,SWORK2,MCHAML
 374 :               IRET=146
 375 :               MOTERR(1:8)='CHASUP  '
 376 :               GO TO 665
 377 :             ENDIF
 378 : 
 379 :           ELSE
 380 :             N2PTEL=0
 381 :             N2EL=0
 382 :           ENDIF
 383 :           SEGINI MELVAL
 384 :           IELVAL(JCOMP)=MELVAL
 385 : *
 386 : *  TRAITEMENT IMMEDIAT SI CHAMP CONSTANT
 387 : *
 388 : *         if(iplac1.eq.4) write(6,*)' n2ptel n1ptel',n2ptel,n1ptelq
 389 :          IF(n2ptel.ne.0) then
 390 :           IF(N2PTEL.EQ.1) THEN
 391 :             DO 4119 IEL=1,N2EL
 392 :               IELCHE(1,IEL)=MELVA1.IELCHE(1,IEL)
 393 :  4119       CONTINUE
 394 : C*        ELSE IF (N2PTEL.NE.1) THEN
 395 :           ELSE
 396 :             IF (MINTE.NE.MINTE1. AND. IPLAC1.NE.IPLACA) THEN
 397 :               SEGDES MELVA1,MELEME,IMODEL,MCHAM1
 398 :               SEGSUP SWORK,SWORK2,MCHAML
 399 :               IRET=755
 400 :               GO TO 665
 401 :             ENDIF
 402 :             DO 4109 IGAU=1,N2PTEL
 403 :             DO 4109 IEL=1,N2EL
 404 :               IELCHE(IGAU,IEL)=MELVA1.IELCHE(IGAU,IEL)
 405 :  4109       CONTINUE
 406 :           ENDIF
 407 :          else
 408 :           IF(N1PTE1.EQ.1) THEN
 409 :             DO 4120 IEL=1,N1EL
 410 :             VELCHE(1,IEL)=MELVA1.VELCHE(1,IEL)
 411 :  4120       CONTINUE
 412 : *
 413 :           ELSE
 414 : *
 415 : *          write (6,*) ' chasup ',swork,melva1,NBPGA1,NBPGAU,NBNN,
 416 : *    >      nel,n1pte1
 417 : *          write (6,*) melva1.velche(/1),melva1.velche(/2)
 418 : 
 419 :            DO 3120 IEL=1,NEL
 420 :            IF(IEL.GT.1.AND.N1EL.EQ.1) GO TO 3130
 421 :              DO 3121 IGAU=1,N1PTE1
 422 :              VAL1(IGAU)=MELVA1.VELCHE(IGAU,IEL)
 423 : 3121         CONTINUE
 424 : C
 425 : C      LE CHAMELEM N'EST PAS AUX NOEUDS
 426 : C
 427 :            IF(MINTE1.NE.0)THEN
 428 : C
 429 : C           MEME SUPPORT( attention test sur iplaca et iplac1 pour DKT)
 430 : C
 431 : *            write(6,*) ' meme support?',minte,minte1,iplac1,iplaca
 432 :             IF(MINTE.EQ.MINTE1. OR. IPLAC1.eq.IPLACA) THEN
 433 :               DO 3124 IGAU=1,N1PTE1
 434 :               VELCHE(IGAU,IEL)=VAL1(IGAU)
 435 : 3124          CONTINUE
 436 : C
 437 : C           SUPPORTS DIFFERENTS
 438 : C
 439 :             ELSE
 440 : C
 441 : C   COQUE INTEGREE OU PAS ?
 442 : C
 443 :                IF(INFMOD(/1).NE.0)THEN
 444 :                    NPINT=INFMOD(1)
 445 :                ELSE
 446 :                   NPINT=0
 447 :                ENDIF
 448 :                IF (NPINT.NE.0.AND.NPINT.NE.1)THEN
 449 :                   IRET = 19
 450 :                   SEGDES MELVA1,MELEME,IMODEL,MCHAM1
 451 :                   SEGSUP SWORK,SWORK2,MCHAML,MELVAL
 452 :                   GO TO 665
 453 :                ENDIF
 454 : C
 454 :               CALL DOXE(XCOOR,IDIM,NBNN,NUM,IEL,XE)
 454 :               CALL QUEDIM(MELGEO,KERRE)
 454 :               CALL CH1CH2(MELE,MINTE,MINTE1,N1PTEL,N1PAUX,NBNN,
 455 :      >                    SWORK,KERRE)
 456 :               IF(KERRE.NE.0) THEN
 457 :                 IRET=KERRE
 458 :                 SEGDES MELVA1,MELEME,IMODEL,MCHAM1
 459 :                 SEGSUP SWORK,SWORK2,MCHAML,MELVAL
 460 :                 GO TO 665
 461 :               ENDIF
 462 : *
 463 :               DO 3122 IGAU=1,N1PTEL
 464 :               VELCHE(IGAU,IEL)=VAL2(IGAU)
 465 : 3122          CONTINUE
 466 :             ENDIF
 467 :           ELSE
 468 :            NBNI=NBNN
 469 :            IF( MELGEO.EQ.12.OR.MELGEO.EQ.13) NBNI=NBNN/2
 470 :              DO 3123 IGAU=1,N1PTEL
 471 :                 VALG=0.D0
 472 :                 DO 3125 INO=1,NBNI
 473 :                  VALG=VALG+SHPTOT(1,INO,IGAU)*VAL1(INO)
 474 : 3125            CONTINUE
 475 :               VELCHE(IGAU,IEL)=VALG
 476 : 3123         CONTINUE
 477 :             ENDIF
 478 : 3120        CONTINUE
 479 : 3130        CONTINUE
 480 : *
 481 :           ENDIF
 482 :          endif
 483 :           SEGDES MELVAL,MELVA1
 484 :  180    CONTINUE
 485 :         SEGSUP SWORK,SWORK2
 486 :         SEGDES MCHAML,MCHAM1,IMODEL,MELEME
 487 : *
 488 :       IF (MINTE.NE.0) SEGDES MINTE
 489 :       IF (MINTE1.NE.0) SEGDES MINTE1
 490 :  100  CONTINUE
 491 :       if (iresu.ne.nsous) then
 492 :         n1=iresu
 493 :         segadj mchelm
 494 :       endif
 495 :  665  CONTINUE
 496 :       SEGDES MCHELM,MCHEL1
 497 :       SEGDES MMODEL
 498 :  666  CONTINUE
 499 :       RETURN
 500 :       END
 501 :  
 502 :