! copyright (c) 2008 Swedish Defence Research Agency (FOI) 
! may not be copied or distributed without written permission from FOI



C	subroutine for rpress.f etc

C	Sven Ivansson  1990




	SUBROUTINE U2TEST (QFAKT,UA2LOK,UB2LOK)
C	test conditions from Hudson p. 18, 206-207
ccc NOT YET IMPLEMENTED FOR ANISOTROPIC LAYER

	USE INMODELa

	IMPLICIT NONE

	INCLUDE 'RPPARAMETER.INC'
C       nol <= noldim

	REAL*16 QFAKT
	COMPLEX*32 UA2LOK,UB2LOK

	REAL*16 VELPHASE,DBL
	COMPLEX*32 CSLASK

	IF (IAZIMI.NE.0) RETURN          ! no test performed in this case

	IF (REAL(UA2LOK).LT.0.0Q0) GOTO 999
	IF (AIMAG(UA2LOK).LT.0.0Q0) GOTO 999
	IF (UB2LOK.NE.(0.0Q0,0.0Q0)) THEN
	  IF (REAL(UB2LOK).LT.0.0Q0) GOTO 999
	  IF (AIMAG(UB2LOK).LT.0.0Q0) GOTO 999
	  CSLASK = 1/UA2LOK - (4.0Q0/3)/UB2LOK
	  IF (REAL(CSLASK).LT.0.0Q0) GOTO 999
	  IF (AIMAG(CSLASK).GT.0.0Q0) GOTO 999
	END IF

	RETURN

 999	WRITE(*,*)
	WRITE(*,*) ' %%% u2test failure'
	CALL U2TOREAL ( QFAKT,UA2LOK, VELPHASE,DBL )
	WRITE(*,*) '  for P ',SNGL(VELPHASE),SNGL(DBL)
	CALL U2TOREAL ( QFAKT,UB2LOK, VELPHASE,DBL )
	WRITE(*,*) '  for S ',SNGL(VELPHASE),SNGL(DBL)
	WRITE(*,*) '  bulk modulus modulo rho'
	IF (UB2LOK.NE.(0.0Q0,0.0Q0)) THEN
	  CSLASK = 1/UA2LOK - (4.0Q0/3)/UB2LOK
	ELSE
	  CSLASK = 1/UA2LOK
	END IF
	WRITE(*,*) '        ',CSLASK
	WRITE(*,*) '  shear modulus modulo rho'
	IF (UB2LOK.NE.(0.0Q0,0.0Q0)) THEN
	  CSLASK = 1/UB2LOK
	ELSE
	  CSLASK = (0.0Q0,0.0Q0)
	END IF
	WRITE(*,*) '        ',CSLASK
	WRITE(*,*) '  both these moduli should have been in the ',
     $	'fourth quadrant'
	WRITE(*,*)
ccc	STOP 605    !!!

	END
