added math_mul33x33, 66x66, and 99x99 to avoid OMP_Critical "evilmatmul"

trunk/math.f90

@@ -231,6 +231,64 @@
  END FUNCTION
 
  
+!**************************************************************************
+! matrix multiplication 3x3
+!**************************************************************************
+ FUNCTION math_mul33x33(A,B)  
+
+ use prec, only: pReal, pInt
+ implicit none
+
+ integer(pInt)  i,j
+ real(pReal), dimension(3,3) ::  math_mul33x33,A,B
+
+ forall (i=1:3,j=1:3) math_mul33x33(i,j) = &
+   A(i,1)*B(1,j) + A(i,2)*B(2,j) + A(i,3)*B(3,j)
+ return
+
+ END FUNCTION
+
+ 
+
+!**************************************************************************
+! matrix multiplication 6x6
+!**************************************************************************
+ FUNCTION math_mul66x66(A,B)  
+
+ use prec, only: pReal, pInt
+ implicit none
+
+ integer(pInt)  i,j
+ real(pReal), dimension(6,6) ::  math_mul66x66,A,B
+
+ forall (i=1:6,j=1:6) math_mul66x66(i,j) = &
+   A(i,1)*B(1,j) + A(i,2)*B(2,j) + A(i,3)*B(3,j) + &
+   A(i,4)*B(4,j) + A(i,5)*B(5,j) + A(i,6)*B(6,j)
+ return
+
+ END FUNCTION
+
+ 
+!**************************************************************************
+! matrix multiplication 9x9
+!**************************************************************************
+ FUNCTION math_mul99x99(A,B)  
+
+ use prec, only: pReal, pInt
+ implicit none
+
+ integer(pInt)  i,j
+ real(pReal), dimension(9,9) ::  math_mul99x99,A,B
+
+ forall (i=1:9,j=1:9) math_mul99x99(i,j) = &
+   A(i,1)*B(1,j) + A(i,2)*B(2,j) + A(i,3)*B(3,j) + &
+   A(i,4)*B(4,j) + A(i,5)*B(5,j) + A(i,6)*B(6,j) + &
+   A(i,7)*B(7,j) + A(i,8)*B(8,j) + A(i,9)*B(9,j)
+ return
+
+ END FUNCTION
+
+ 
 
 !**************************************************************************
 ! Cramer inversion of 3x3 matrix
@@ -823,9 +881,11 @@
  real(pReal), dimension(3,3) :: r
  real(pReal) math_disorient, tr
 
-!$OMP CRITICAL (evilmatmul)
+!$OMP CRITICAL (evilmatmul)
+
  r = matmul(math_EulerToR(EulerB),transpose(math_EulerToR(EulerA)))
-!$OMP END CRITICAL (evilmatmul)
+!$OMP END CRITICAL (evilmatmul)
+
  tr = (r(1,1)+r(2,2)+r(3,3)-1.0_pReal)*0.4999999_pReal
  math_disorient = abs(0.5_pReal*pi-asin(tr))
  return
@@ -889,10 +949,13 @@ endif
    disturb(2) = sign(1.0_pReal,rnd(2))*acos(cosScatter+(1.0_pReal-cosScatter)*rnd(4)) ! Phi
    disturb(3) = scatter * rnd(2)                                                      ! phi2
    if (rnd(5) <= exp(-1.0_pReal*(math_disorient(origin,disturb)/scatter)**2)) exit   
- enddo
+ enddo
-!$OMP CRITICAL (evilmatmul)
+
+!$OMP CRITICAL (evilmatmul)
+
  math_sampleGaussOri = math_RtoEuler(matmul(math_EulerToR(disturb),math_EulerToR(center)))
-!$OMP END CRITICAL (evilmatmul)
+!$OMP END CRITICAL (evilmatmul)
+
  return
  
  END FUNCTION
@@ -966,9 +1029,11 @@ endif
  pRot = math_RodrigtoR(axis,angle)
 
 ! ---# apply the three rotations #---
-!$OMP CRITICAL (evilmatmul)
+!$OMP CRITICAL (evilmatmul)
+
 math_sampleFiberOri = math_RtoEuler(matmul(pRot,matmul(fRot,oRot))) 
-!$OMP END CRITICAL (evilmatmul)
+!$OMP END CRITICAL (evilmatmul)
+
  return
 
  END FUNCTION
@@ -1035,17 +1100,23 @@ math_sampleFiberOri = math_RtoEuler(matmul(pRot,matmul(fRot,oRot)))
  real(pReal) FE(3,3),R(3,3),U(3,3),CE(3,3),EW1,EW2,EW3,EB1(3,3),EB2(3,3),EB3(3,3),UI(3,3),det
 
  error = .false.
-!$OMP CRITICAL (evilmatmul)
+!$OMP CRITICAL (evilmatmul)
+
  ce=matmul(transpose(fe),fe)
-!$OMP END CRITICAL (evilmatmul)
+!$OMP END CRITICAL (evilmatmul)
+
  CALL math_spectral1(CE,EW1,EW2,EW3,EB1,EB2,EB3)
  U=DSQRT(EW1)*EB1+DSQRT(EW2)*EB2+DSQRT(EW3)*EB3
  call math_invert3x3(U,UI,det,error)
- if (.not. error) then
+ if (.not. error) then
-!$OMP CRITICAL (evilmatmul)
+
+!$OMP CRITICAL (evilmatmul)
+
  R = matmul(fe,ui)
-!$OMP END CRITICAL (evilmatmul)
+!$OMP END CRITICAL (evilmatmul)
- endif
+
+ endif
+
  return 
  
  END SUBROUTINE
@@ -1102,9 +1173,11 @@ math_sampleFiberOri = math_RtoEuler(matmul(pRot,matmul(fRot,oRot)))
   D3=1.0_pReal/(EW3-EW1)/(EW3-EW2)
   M1=M-EW1*math_I3
   M2=M-EW2*math_I3
-!$OMP CRITICAL (evilmatmul)
+!$OMP CRITICAL (evilmatmul)
+
   EB3=MATMUL(M1,M2)*D3
-!$OMP END CRITICAL (evilmatmul)
+!$OMP END CRITICAL (evilmatmul)
+
   EB1=math_I3-EB3
 !  both EB2 and EW2 are set to zero so that they do not
 !  contribute to U in PDECOMPOSITION
@@ -1114,9 +1187,11 @@ math_sampleFiberOri = math_RtoEuler(matmul(pRot,matmul(fRot,oRot)))
   D1=1.0_pReal/(EW1-EW2)/(EW1-EW3)
   M2=M-math_I3*EW2
   M3=M-math_I3*EW3
-!$OMP CRITICAL (evilmatmul)
+!$OMP CRITICAL (evilmatmul)
+
   EB1=MATMUL(M2,M3)*D1
-!$OMP END CRITICAL (evilmatmul)
+!$OMP END CRITICAL (evilmatmul)
+
   EB2=math_I3-EB1
 !  both EB3 and EW3 are set to zero so that they do not
 !  contribute to U in PDECOMPOSITION
@@ -1126,9 +1201,11 @@ math_sampleFiberOri = math_RtoEuler(matmul(pRot,matmul(fRot,oRot)))
   D2=1.0_pReal/(EW2-EW1)/(EW2-EW3) 
   M1=M-math_I3*EW1
   M3=M-math_I3*EW3
-!$OMP CRITICAL (evilmatmul)
+!$OMP CRITICAL (evilmatmul)
+
   EB2=MATMUL(M1,M3)*D2
-!$OMP END CRITICAL (evilmatmul)
+!$OMP END CRITICAL (evilmatmul)
+
   EB1=math_I3-EB2
 !  both EB3 and EW3 are set to zero so that they do not
 !  contribute to U in PDECOMPOSITION
@@ -1141,11 +1218,13 @@ math_sampleFiberOri = math_RtoEuler(matmul(pRot,matmul(fRot,oRot)))
   M1=M-EW1*math_I3
   M2=M-EW2*math_I3
   M3=M-EW3*math_I3
-!$OMP CRITICAL (evilmatmul)
+!$OMP CRITICAL (evilmatmul)
+
   EB1=MATMUL(M2,M3)*D1
   EB2=MATMUL(M1,M3)*D2
   EB3=MATMUL(M1,M2)*D3
-!$OMP END CRITICAL (evilmatmul)
+!$OMP END CRITICAL (evilmatmul)
+
    END IF
  END IF
  RETURN
@@ -1610,7 +1689,8 @@ math_sampleFiberOri = math_RtoEuler(matmul(pRot,matmul(fRot,oRot)))
  r(1:ndim) = 0.0_pReal
 
  if ( any ( base(1:ndim) <= 1 ) ) then
-!$OMP CRITICAL (write2out)
+!$OMP CRITICAL (write2out)
+
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'I_TO_HALTON - Fatal error!'
    write ( *, '(a)' ) ' An input base BASE is <= 1!'
@@ -1618,7 +1698,8 @@ math_sampleFiberOri = math_RtoEuler(matmul(pRot,matmul(fRot,oRot)))
      write ( *, '(i6,i6)' ) i, base(i)
    end do
    call flush(6)
-!$OMP END CRITICAL (write2out)
+!$OMP END CRITICAL (write2out)
+
    stop
  end if
 
@@ -1888,13 +1969,15 @@ math_sampleFiberOri = math_RtoEuler(matmul(pRot,matmul(fRot,oRot)))
    prime = npvec(n)
  else
    prime = 0
-!$OMP CRITICAL (write2out)
+!$OMP CRITICAL (write2out)
+
    write ( 6, '(a)' ) ' '
    write ( 6, '(a)' ) 'PRIME - Fatal error!'
    write ( 6, '(a,i6)' ) '  Illegal prime index N = ', n
    write ( 6, '(a,i6)' ) '  N must be between 0 and PRIME_MAX =',prime_max
    call flush(6)
-!$OMP END CRITICAL (write2out)
+!$OMP END CRITICAL (write2out)
+
    stop
  end if