Télécharger la plaquette Cast3M


fr en

Télécharger prtens.eso

Retour à la liste

Numérotation des lignes : 

prtens

  1. C PRTENS    SOURCE    GOUNAND   26/01/16    21:15:08     12450          
  2.       SUBROUTINE PRTENS()
  3.       IMPLICIT REAL*8 (A-H,O-Z)
  4.       IMPLICIT INTEGER (I-N)
  5. C***********************************************************************
  6. C NOM         : PRTENS
  7. C DESCRIPTION : Opérations sur des tenseurs (unaires pour l'instant)
  8. C
  9. C
  10. C
  11. C LANGAGE     : ESOPE
  12. C AUTEUR      : Stephane GOUNAND (CEA/DES/ISAS/DM2S/SEMT/LTA)
  13. C               mel : gounand@semt2.smts.cea.fr
  14. C***********************************************************************
  15. C APPELES          :
  16. C APPELES (E/S)    :
  17. C APPELES (BLAS)   :
  18. C APPELES (CALCUL) :
  19. C APPELE PAR       :
  20. C***********************************************************************
  21. C SYNTAXE GIBIANE    :
  22. C ENTREES            :
  23. C ENTREES/SORTIES    :
  24. C SORTIES            :
  25. C***********************************************************************
  26. C VERSION    : v1, 28/08/2024, version initiale
  27. C HISTORIQUE : v1, 28/08/2024, creation
  28. C HISTORIQUE :
  29. C HISTORIQUE :
  30. C***********************************************************************
  31. -INC PPARAM
  32. -INC CCOPTIO
  33. -INC SMCHPOI
  34. -INC SMLMOTS
  35. *
  36.       PARAMETER (NOTENS=14)
  37.       CHARACTER*8 MOTENS(NOTENS),TYCHA
  38.       CHARACTER*(LOCOMP) MOCOMP,CCCOMP
  39. C
  40.       DATA MOTENS/'NORM2','NORMINF','DET','TRACE','INVERSE','IDEN','LOG'
  41.      $     ,'EXP','INVS','ABSOLU','PRINCIPA','RECOMPOS','TRANSPOS'
  42.      $     ,'VALP'/
  43. *
  44. * Executable statements
  45. *
  46. * Mot-clé
  47.       CALL LIRMOT(MOTENS,-NOTENS,IOTENS,1)
  48.       IF(IERR.NE.0) RETURN
  49. *      write(ioimp,*) 'MOTENS,IOTENS=',MOTENS(IOTENS),IOTENS
  50. * Lecture du champ
  51.       TYCHA='CHPOINT '
  52.       CALL LIROBJ(TYCHA,ICHA,0,IRET)
  53.       IF (IRET.EQ.0) THEN
  54.          TYCHA='MCHAML  '
  55.          CALL LIROBJ(TYCHA,ICHA,1,IRET)
  56.          IF(IERR.NE.0) RETURN
  57.       ENDIF
  58.       CALL ACTOBJ(TYCHA,ICHA,1)
  59. *
  60.       DO 1000 ITRY=1,2
  61. * Lecture des noms de composantes
  62.          CALL LIROBJ('LISTMOTS',MLMOTS,ITRY-1,ILMOTS)
  63.          IF (ILMOTS.EQ.0) THEN
  64.             IF (TYCHA.EQ.'CHPOINT') THEN
  65.                CALL EXTR11(ICHA,MLMOTS)
  66.                IF(IERR.NE.0) RETURN
  67.             ELSEIF (TYCHA.EQ.'MCHAML') THEN
  68.                CALL EXTR17(ICHA,MLMOTS)
  69.                IF(IERR.NE.0) RETURN
  70.             ELSE
  71. * On ne veut pas d'objet de type %m1:8
  72.                MOTERR(1:8)=TYCHA
  73.                CALL ERREUR(39)
  74.                RETURN
  75.             ENDIF
  76. * Recomposition
  77.             IF (IOTENS.EQ.12) THEN
  78.                JGM=IDIM*(IDIM+1)
  79.                JGN=LOCOMP
  80.                SEGINI MLMOT1
  81.                ICMP=0
  82.                CCCOMP='SI'
  83.                DO i=1,IDIM
  84.                   WRITE(CCCOMP(3:3),FMT='(I1)') I
  85.                   WRITE(CCCOMP(4:4),FMT='(I1)') I
  86.                   ICMP=ICMP+1
  87.                   MLMOT1.MOTS(ICMP)=CCCOMP
  88.                ENDDO
  89.                CCCOMP='CO'
  90.                DO i=1,IDIM
  91.                   WRITE(CCCOMP(4:4),FMT='(I1)') I
  92.                   DO j=1,IDIM
  93.                      WRITE(CCCOMP(3:3),FMT='(I1)') J
  94.                      ICMP=ICMP+1
  95.                      MLMOT1.MOTS(ICMP)=CCCOMP
  96.                   ENDDO
  97.                ENDDO
  98. * Verifions la présence de toutes les composantes dans la liste devinee
  99.                ICMP=0
  100.                DO I=1,MOTS(/2)
  101.                   CALL PLACE (MLMOT1.MOTS,MLMOT1.MOTS(/2),IPLAC,MOTS(I))
  102.                   IF (IPLAC.NE.0) ICMP=ICMP+1
  103.                ENDDO
  104. *         write(ioimp,*) 'ICMP=',ICMP
  105.                IF (ICMP.NE.MOTS(/2)) THEN
  106.                   SEGSUP MLMOT1
  107.                   MLMOT1=0
  108.                ENDIF
  109.             ELSE
  110.                CALL GUESCO(TYCHA,MLMOTS,MLMOT1)
  111.             ENDIF
  112.             IF(IERR.NE.0) RETURN
  113.             SEGSUP MLMOTS
  114.             MLMOTS=MLMOT1
  115.             IF (MLMOTS.EQ.0) THEN
  116.                GOTO 1000
  117.             ELSE
  118.                if (IIMPI.NE.0) THEN
  119.                   write(ioimp,*) 'On a devine les composantes :'
  120.                   write(ioimp,'(10(1X,A))') 'MLMOTS=',(MOTS(i),i=1
  121.      $                 ,MOTS(/2))
  122.                endif
  123.                GOTO 1001
  124.             ENDIF
  125.          ENDIF
  126.  1000 CONTINUE
  127.  1001 CONTINUE
  128. * Pour le message d'erreur 803 éventuellement appelé dans tens1
  129.       MOTERR(1:8)=MOTENS(IOTENS)
  130.       CALL TENS1(ICHA,TYCHA,MLMOTS,IOTENS,ICHA1)
  131.       IF(IERR.NE.0) RETURN
  132. *
  133.       IF (ILMOTS.EQ.0) SEGSUP MLMOTS
  134. *
  135.       CALL ACTOBJ(TYCHA,ICHA1,1)
  136.       CALL ECROBJ(TYCHA,ICHA1)
  137. *
  138. * Normal termination
  139. *
  140.       RETURN
  141. *
  142. * Format handling
  143. *
  144. *
  145. * Error handling
  146. *
  147. *
  148. * End of subroutine PRTENS
  149. *
  150.       END
  151.  
  152.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales