Télécharger la plaquette Cast3M


fr en

Télécharger mulatb.eso

Retour à la liste

Numérotation des lignes : 

mulatb

  1. C MULATB    SOURCE    AM        12/02/28    00:28:37     7289
  2.  
  3.  
  4.       SUBROUTINE MULATB(A,B,R,ia,ja,ib,jb)
  5. C
  6. C     ***************************************************************
  7. C     *                                                             *
  8. C     *            MULTIPLICATION OF Atranspose BY B                *
  9. C     *            ---------------------------------                *
  10. C     *                                                             *
  11. C     *   INPUT : A,B : MATRIX TO MULTIPLY                          *
  12. C     *                                                             *
  13. C     *  OUTPUT :   R : RESULT                                      *
  14. C     *                                                             *
  15. C     ***************************************************************
  16. C
  17.       IMPLICIT REAL*8 (A-B,D-H,O-Z)
  18.       implicit integer (I-K,M,N)
  19.       implicit logical (L)
  20.       implicit character*10 (C)
  21.  
  22.       parameter (idimrloc = 441)
  23.  
  24.       DIMENSION A(ia,ja),B(ib,jb),R(ja,jb)
  25.  
  26.       dimension rloc(idimrloc)
  27.  
  28. c     rloc is introduced to allow the results of R to be stored in A or in B
  29. c     Example : Call mulATB(A,B,A,...)
  30. c          or   Call mulATB(A,B,B,...)
  31.  
  32.       i1 = 1
  33.       i0 = 0
  34.       i3 = 3
  35.       i6 = 6
  36.       r0 = 0.
  37.  
  38.       if (ja*jb.gt.idimrloc) then
  39.         write(2,3)ja,jb,ja*jb,idimrloc
  40.     3   format(' ERROR from subr. MULATB.'/
  41.      .  '   The dimensions of the result matrix are ',i3,'X',i3,' = ',
  42.      .  i6,' > ',i6/
  43.      .  '   Change idimrloc in MULATB')
  44.         stop
  45.       endif
  46.  
  47.       if (ia.ne.ib) then
  48.         write(2,2000) ja,ia,ib,jb
  49.         write(*,2000) ja,ia,ib,jb
  50.  2000   format(' ERROR in subr. MULATB.'/
  51.      .         ' It is impossible to multiply a matrix of dimensions',I3
  52.      .  ,' x',i3/
  53.      .         '                           by a matrix of dimensions',I3
  54.      .  ,' x',i3)
  55.         stop
  56.       endif
  57.  
  58.       iloc = i0
  59.       DO 1 J=i1,jb
  60.         DO 1 I=i1,ja
  61.           iloc = iloc+i1
  62.           SUM = r0
  63.           DO 2 K=i1,ia
  64.              SUM = SUM+A(K,I)*B(K,J)
  65.     2     CONTINUE
  66.           rloc(iloc) = SUM
  67.     1 CONTINUE
  68.  
  69.       call AequalB(R,rloc,ja,jb,i1,i1)
  70. c     **** *******
  71.  
  72.       RETURN
  73.       END
  74.  
  75.  
  76.  
  77.  

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