Sources Esope | Cast3M

hrsi
C HRSI      SOURCE    PV        20/09/28    21:15:13     10727          
      SUBROUTINE HRSI
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
C************************************************************************
C     I    OBJET
C     ----------
C     CALCUL DES HR (GRADIENTS FF) ELEMENTAIRES SOUS INTEGRES
C
C
C     II SYNTAXE
C     ___________
C
C     RES = HRSI OBJ1 &lt;'AXI' i >  &lt;'IMPR'>
C
C     OBJ1 : Objet MAILLAGE
C     AXI    DISCRETISATION CORDONNEES CYLINDRIQUE  (2D)
C        i=1 AXE DE SYMETRIE y=0
C        i=2 AXE DE SYMETRIE x=0
C     IMPR : impressions de controle
 
C     RES : Resultat objet de type MATESI
C************************************************************************
C
-INC CCGEOME
 
-INC PPARAM
-INC CCOPTIO
-INC SMTABLE
      POINTEUR MTABD.MTABLE
-INC SMMATRIK
-INC SIZFFB
-INC SMCOORD
-INC SMELEME
      POINTEUR MELEMZ.MELEME
      CHARACTER*8 NMD,NOM0,NOM,TYPE,LISTM(1)
      DIMENSION HRT(24),RPGJ(9),XYZI(24)
      PARAMETER (NTB=1)
      CHARACTER*8 LTAB(NTB)
      DIMENSION KTAB(NTB)
      DATA LTAB/'DOMAINE '/
      DATA LISTM/'IMPR    '/
C*****************************************************************************
 
      CALL LITABS(LTAB,KTAB,NTB,1,IRET)
      IF (IERR.NE.0) RETURN
      MTABD=KTAB(1)
 
      IAXI=0
      IF(IFOMOD.EQ.0)IAXI=2
      IMPAP=0
 1    CONTINUE
      CALL LIRCHA(NOM,0,IRET)
      IF(IRET.NE.0)THEN
      CALL OPTLI(IP,LISTM,NOM,1)
      IF(IP.EQ.0)THEN
      WRITE(6,*)' On attend le mot cle IMPR'
C Il manque la donnée d'un mot clé.
      CALL ERREUR(498)
      RETURN
      ELSE
      IMPAP=1
      GO TO 1
      ENDIF
      ENDIF
C
      TYPE='MAILLAGE'
      CALL ACMO(MTABD,'MAILLAGE',TYPE,MELEMZ)
      CALL ACMO(MTABD,'SOMMET',TYPE,MELES1)
      CALL ACMO(MTABD,'CENTRE',TYPE,MELEMC)
      IF (IERR.NE.0) RETURN
 
      SEGACT MELEMZ
      NBSOUS=MELEMZ.LISOUS(/1)
      IF(NBSOUS.EQ.0)NBSOUS=1
C
C  ON CREE L OBJET MATRIK
C
      NRIGE=7
      NKID =9
      NKMT =7
      NMATRI=1
      SEGINI MATRIK
      IRIGEL(1,1)=MELEMZ
      IRIGEL(2,1)=MELEMZ
      IRIGEL(7,1)=1
      NBOP=0
      NBELC=0
      NBME=1
      IF(IAXI.NE.0)NBME=2
      SEGINI IMATRI
      IRIGEL(4,1)=IMATRI
C     KGEOS=MELES1
      KSPGP=MELES1
C     KGEOC=MELEMC
      KSPGD=MELEMC
 
C
C        BOUCLE SUR LES TYPES D'ELEMENTS ET CALCUL
C
      DO 81 KSOUS=1,NBSOUS
      IF(NBSOUS.EQ.1)IPT1=MELEMZ
      IF(NBSOUS.NE.1)IPT1=MELEMZ.LISOUS(KSOUS)
      SEGACT IPT1
 
      NOM0=NOMS(IPT1.ITYPEL)//'    '
C
      CALL KALPBG(NOM0,'FONFORM0',IZFFM)
      SEGACT IZFFM*MOD
      IZHR=KZHR(1)
      SEGACT IZHR*MOD
 
      NBEL=IPT1.NUM(/2)
      IF(IAXI.NE.0)THEN
      NP=1
      MP=1
      SEGINI IPM1
      LIZAFM(KSOUS,2)=IPM1
      ENDIF
      NP=IPT1.NUM(/1)
      NES=GR(/1)
      NPG=GR(/3)
      MP=NES
      IESP=MP
      SEGINI IZAFM
C
      SEGACT IPT1
      LIZAFM(KSOUS,1)=IZAFM
 
      IF(IMPAP.NE.0)THEN
      WRITE(6,*)' CREATION SEGMENT MATRIK '
      WRITE(6,*)' FONCTIONS DE FORME '
      WRITE(6,1002)((FN(MM,II),MM=1,NP),II=1,NPG)
      WRITE(6,*)' FONCTIONS DE FORME '
      WRITE(6,1002)((GR(1,MM,II),MM=1,NP),II=1,NPG)
      WRITE(6,1002)((GR(2,MM,II),MM=1,NP),II=1,NPG)
      ENDIF
 
      DO 8 K=1,NBEL
      IJ=1
      DO   I=1,NP
      J=IPT1.NUM(I,K)
      DO   N=1,IESP
       XYZI(IJ )=XCOOR((J-1)*(IDIM+1)+N)
      IJ=IJ+1
      ENDDO
      ENDDO
C
      CALL CALJBC(FN,GR,PG,XYZI,HRT,PGSQ,RPGJ,NES,
     *IESP,NP,NPG,IAXI,AIRE)
      IH=0
      DO  I=1,NP
      DO  N=1,IESP
      IH=IH+1
      AM(K,I,N)=HRT(IH)
      ENDDO
      ENDDO
      IF(IAXI.NE.0)IPM1.AM(K,1,1)=RPGJ(1)
 
 
  8   CONTINUE
      IF(IPT1.NE.MELEMZ)SEGDES IPT1
      SEGDES IZAFM
      IF(IAXI.NE.0)SEGDES IPM1
      SEGSUP IZFFM,IZHR
  81  CONTINUE
      SEGDES MELEMZ,IMATRI
   32 CONTINUE
      SEGDES MATRIK
      CALL ECROBJ('MATRIK',MATRIK)
      RETURN
 1002 FORMAT(10(1X,1PE11.4))
      END