Esope source files

   1 : C PRMET     SOURCE    GOUNAND   05/12/21    21:35:43     5281           
   2 :       SUBROUTINE PRMET(JMAJAC,JMAREG,
   3 :      $     JSDETG,JIG,JIGH,JIGHIG,
   4 :      $     IMPR,IRET)
   5 :       IMPLICIT REAL*8 (A-H,O-Z)
   6 :       IMPLICIT INTEGER (I-N)
   7 : C***********************************************************************
   8 : C NOM         : PRMET
   9 : C DESCRIPTION : Informations de préconditionnement pour la métrique
  10 : C
  11 : C
  12 : C
  13 : C LANGAGE     : ESOPE
  14 : C AUTEUR      : Stéphane GOUNAND (CEA/DEN/DM2S/SFME/LTMF)
  15 : C               mél : gounand@semt2.smts.cea.fr
  16 : C***********************************************************************
  17 : C APPELES          : 
  18 : C APPELES (E/S)    : 
  19 : C APPELES (BLAS)   :
  20 : C APPELES (CALCUL) :
  21 : C APPELE PAR       :
  22 : C***********************************************************************
  23 : C SYNTAXE GIBIANE    :
  24 : C ENTREES            :
  25 : C ENTREES/SORTIES    :
  26 : C SORTIES            :
  27 : C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
  28 : C***********************************************************************
  29 : C VERSION    : v1, ??/??/2005, version initiale
  30 : C HISTORIQUE : v1, ??/??/2005, création
  31 : C HISTORIQUE :
  32 : C HISTORIQUE :
  33 : C***********************************************************************
  34 : C Prière de PRENDRE LE TEMPS de compléter les commentaires
  35 : C en cas de modification de ce sous-programme afin de faciliter
  36 : C la maintenance !
  37 : C***********************************************************************
  38 : -INC CCOPTIO
  39 : CBEGININCLUDE SMCHAEL
  40 :       SEGMENT MCHAEL
  41 :       POINTEUR IMACHE(N1).MELEME
  42 :       POINTEUR ICHEVA(N1).MCHEVA
  43 :       ENDSEGMENT
  44 :       SEGMENT MCHEVA
  45 :       REAL*8 VELCHE(NBLIG,NBCOL,N2LIG,N2COL,NBPOI,NBELM)
  46 :       ENDSEGMENT
  47 :       SEGMENT LCHEVA
  48 :       POINTEUR LISCHE(NBCHE).MCHEVA
  49 :       ENDSEGMENT
  50 : CENDINCLUDE SMCHAEL
  51 :       INTEGER NBLIG,NBCOL,N2LIG,N2COL,NBPOI,NBELM
  52 :       POINTEUR JMAJAC.MCHEVA
  53 :       POINTEUR JMAREG.MCHEVA
  54 :       POINTEUR JSDETG.MCHEVA,JIG.MCHEVA,JIGH.MCHEVA,JIGHIG.MCHEVA
  55 :       POINTEUR G.MCHEVA
  56 : -INC TMXMAT      
  57 :       POINTEUR H.MXMAT
  58 : *
  59 :       LOGICAL LBID
  60 :       INTEGER IMPR,IRET
  61 : *     
  62 : * Executable statements
  63 : *
  64 :       IF (IMPR.GT.2) WRITE(IOIMP,*) 'Entrée dans prmet.eso' 
  65 : *
  66 : * Dimensions
  67 : *      
  68 :       NLJA=JMAJAC.VELCHE(/6)
  69 :       NPJA=JMAJAC.VELCHE(/5)
  70 :       IREF=JMAJAC.VELCHE(/4)
  71 :       IREL=JMAJAC.VELCHE(/3)
  72 : *
  73 : * Initialisations
  74 : *
  75 :       NBELM=NLJA
  76 :       NBPOI=NPJA
  77 :       N2COL=1
  78 :       N2LIG=1
  79 :       NBCOL=1
  80 :       NBLIG=1
  81 :       SEGINI JSDETG
  82 :       N2COL=IREF
  83 :       N2LIG=IREF
  84 :       SEGINI,G
  85 :       SEGINI JIG
  86 :       SEGINI JIGH
  87 :       SEGINI JIGHIG
  88 : * Objets temporaires
  89 :       LDIM1=IREF
  90 :       LDIM2=IREF
  91 :       SEGINI,H
  92 : *
  93 : * Calcul de la métrique des éléments réguliers
  94 : *
  95 : C      SEGPRT,JMAJAC
  96 : C      SEGPRT,JMAREG
  96 :       CALL MAMA(JMAREG.VELCHE,IREF,IREF,
  97 :      $     'JTJ     ',H.XMAT,IREF,IREF,
  98 :      $     IMPR,IRET)
  99 :       IF (IRET.NE.0) GOTO 9999
 100 : C      SEGPRT,H
 101 : *
 102 : * Calcul de la métrique G
 103 : *
 104 :       DO ILJA=1,NLJA
 105 :          DO IPJA=1,NPJA
 105 :             CALL MAMA(JMAJAC.VELCHE(1,1,1,1,IPJA,ILJA),IREL,IREF,
 106 :      $           'JTJ     ',G.VELCHE(1,1,1,1,IPJA,ILJA),IREF,IREF,
 107 :      $           IMPR,IRET)
 108 :             IF (IRET.NE.0) GOTO 9999
 109 :          ENDDO
 110 :       ENDDO
 111 : *
 112 : * Calcul de l'inverse et du déterminant
 113 : *
 114 :       LBID=.FALSE.
 115 : C      WRITE(IOIMP,*) 'GEOLI2'
 116 : C      WRITE(IOIMP,*) 'IREF=',IREF
 117 : C      WRITE(IOIMP,*) 'NPJA=',NPJA
 118 : C      WRITE(IOIMP,*) 'NLJA=',NLJA
 119 : C      WRITE(IOIMP,*) 'LBID=',LBID
 120 : C      SEGPRT,G
 120 :       CALL GEOLI2(IREF,NPJA,NLJA,G.VELCHE,
 121 :      $     JIG.VELCHE,JSDETG.VELCHE,LBID,IMPR,IRET)
 122 :       IF (IRET.NE.0) GOTO 9999
 123 : *      SEGSUP,G
 124 : C      SEGPRT,JIG
 125 : *
 126 : * Racine du déterminant
 127 : *
 128 :       DO ILJA=1,NLJA
 129 :          DO IPJA=1,NPJA
 130 :             JSDETG.VELCHE(1,1,1,1,IPJA,ILJA)=
 131 :      $           SQRT(JSDETG.VELCHE(1,1,1,1,IPJA,ILJA))
 132 :          ENDDO
 133 :       ENDDO
 134 : C      SEGPRT,JSDETG
 135 : *
 136 : * g-1h
 137 : *
 138 :       DO ILJA=1,NLJA
 139 :          DO IPJA=1,NPJA
 139 :             CALL MAMAMA(JIG.VELCHE(1,1,1,1,IPJA,ILJA),IREF,IREF,
 140 :      $           H.XMAT,IREF,IREF,
 141 :      $           'FOIS    ',JIGH.VELCHE(1,1,1,1,IPJA,ILJA),IREF,IREF,
 142 :      $           IMPR,IRET)
 143 :             IF (IRET.NE.0) GOTO 9999
 144 :          ENDDO
 145 :       ENDDO
 146 : *
 147 : * g-1hg-1
 148 : *
 149 :       DO ILJA=1,NLJA
 150 :          DO IPJA=1,NPJA
 150 :             CALL MAMAMA(JIGH.VELCHE(1,1,1,1,IPJA,ILJA),IREF,IREF,
 151 :      $           JIG.VELCHE(1,1,1,1,IPJA,ILJA),IREF,IREF,
 152 :      $           'FOIS    ',JIGHIG.VELCHE(1,1,1,1,IPJA,ILJA),IREF,IREF,
 153 :      $           IMPR,IRET)
 154 :             IF (IRET.NE.0) GOTO 9999
 155 :          ENDDO
 156 :       ENDDO
 157 :       SEGSUP H
 158 : *
 159 : * Normal termination
 160 : *
 161 :       IRET=0
 162 :       RETURN
 163 : *
 164 : * Format handling
 165 : *
 166 : *
 167 : * Error handling
 168 : *
 169 :  9999 CONTINUE
 170 :       IRET=1
 171 :       WRITE(IOIMP,*) 'An error was detected in subroutine prmet'
 172 :       RETURN
 173 : *
 174 : * End of subroutine PRMET
 175 : *
 176 :       END
 177 : 
 178 :