Esope source files

   1 : C PRRACC    SOURCE    FANDEUR   10/08/30    21:15:39     6732           
   2 : C
   3 : C   CE SOUS PROGRAMME PREPARE LES DONNEES POUR LES ELEMENTS
   4 : C   RACCORD NORMAUX OU LES ELEMENTS RACCORD POREUX (BALD)
   5 : C 
   6 :       SUBROUTINE PRRACC               
   7 :       IMPLICIT INTEGER(I-N)
   8 :       IMPLICIT REAL*8(A-H,O-Z)
   9 : 
  10 : -INC CCOPTIO                          
  11 : -INC CCGEOME                          
  12 : -INC SMELEME                          
  13 : 
  14 :       XXX=DENSIT/10.                                                   
  14 :       CALL LIRREE(XXX,0,IRETOU)                                        
  15 :       IF (IERR.NE.0) RETURN                                            
  16 :       CRIT=ABS(XXX)
  17 :       IF (CRIT.EQ.0.) THEN
  17 :         CALL ERREUR(21)                                  
  18 :         RETURN                                            
  19 :       ENDIF
  20 : 
  21 :       IPT3=0                                                       
  21 :       CALL LIROBJ('MAILLAGE',IPT1,1,IRETOU)                            
  22 :       IF (IERR.NE.0) RETURN
  22 :       CALL LIROBJ('MAILLAGE',IPT2,1,IRETOU)
  23 :       IF (IERR.NE.0) RETURN
  23 :       CALL LIROBJ('MAILLAGE',IPT3,0,IRETOU)
  24 :       IF (IERR.NE.0) RETURN
  25 : C                                            
  26 :       SEGACT IPT1                                                               
  27 :       IF (IPT1.LISOUS(/1).NE.0) GOTO 102                                        
  28 :       IF (KSURF(IPT1.ITYPEL).EQ.0) GOTO 101                                     
  29 :  102  CONTINUE                                                                  
  29 :       CALL ECROBJ('MAILLAGE',IPT1)
  29 :       CALL PRCONT 
  29 :       CALL LIROBJ('MAILLAGE',IPT1,1,IRETOU)                                     
  30 :       IF (IERR.NE.0) RETURN                                                     
  31 :       SEGACT IPT1                                                               
  32 :  101  CONTINUE
  33 : C                                                                  
  34 :       SEGACT IPT2                                                               
  35 :       IF (IPT2.LISOUS(/1).NE.0) GOTO 202                                       
  36 :       IF (KSURF(IPT2.ITYPEL).EQ.0) GOTO 201                                       
  37 :  202  CONTINUE                                                                  
  37 :       CALL ECROBJ('MAILLAGE',IPT2)                                              
  37 :       CALL PRCONT                                                               
  37 :       CALL LIROBJ('MAILLAGE',IPT2,1,IRETOU)                                     
  38 :       IF (IERR.NE.0) RETURN                                                     
  39 :       SEGACT IPT2                                                               
  40 :  201  CONTINUE
  41 : C
  42 :       IF(IPT3.NE.0)THEN
  43 : C
  44 : C  CAS DES ELELMENTS JOINTS POREUX
  45 : C
  46 :         SEGACT IPT3                                                             
  47 :         IF (IPT3.LISOUS(/1).NE.0) GOTO 302                                      
  48 :         IF (KSURF(IPT3.ITYPEL).EQ.0) GOTO 301                                   
  49 :  302    CONTINUE                                                                
  50 :         SEGDES IPT1,IPT2,IPT3
  50 :         CALL ERREUR(26)
  51 :         RETURN                                                     
  52 :  301    CONTINUE
  52 :         CALL RACPOR(IPT1,IPT2,IPT3,IPT4,CRIT)
  53 :         SEGDES IPT1,IPT2,IPT3
  54 : C  
  55 :       ELSE             
  56 : C
  57 : C  CAS DES ELELMENTS JOINTS NORMAUX
  58 : C
  58 :         CALL RACCOR(IPT1,IPT2,IPT4,CRIT)
  59 :         SEGDES IPT1,IPT2
  60 : C
  61 :       END IF
  62 : C                                          
  63 :       IF (IERR.NE.0) RETURN                                                     
  64 :       SEGDES IPT4                                                             
  64 :       CALL ECROBJ('MAILLAGE',IPT4)                                              
  65 : 
  66 :       RETURN                                                                    
  67 :       END                                                                       
  68 : 
  69 :