crank_revealing.F

Go to the documentation of this file.

C
C  This file is part of MUMPS 5.5.1, released
C  on Tue Jul 12 13:17:24 UTC 2022
C
C
C  Copyright 1991-2022 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria,
C  Mumps Technologies, University of Bordeaux.
C
C  This version of MUMPS is provided to you free of charge. It is
C  released under the CeCILL-C license 
C  (see doc/CeCILL-C_V1-en.txt, doc/CeCILL-C_V1-fr.txt, and
C  https://cecill.info/licences/Licence_CeCILL-C_V1-en.html)
C
      SUBROUTINE cmumps_get_ns_options_facto(N,KEEP,ICNTL,MPG)
      IMPLICIT NONE
          INTEGER N, KEEP(500), ICNTL(60), MPG
          keep(19)=0
          RETURN
      END SUBROUTINE cmumps_get_ns_options_facto
      SUBROUTINE cmumps_get_ns_options_solve(ICNTL, KEEP, 
     &                                       NRHS, MPG, INFO)
      IMPLICIT NONE
      INTEGER, intent(in)   :: KEEP(500), NRHS, MPG, ICNTL(60)
      INTEGER, intent(inout):: INFO(80)
      IF (keep(19).EQ.0.AND.keep(110).EQ.0) THEN
        IF (keep(111).NE.0) THEN
         info(1) = -37
         info(2) = 56  
         IF (keep(110).EQ.0) info(2) = 24 
          IF(mpg.GT.0) THEN
           WRITE( mpg,'(A)')
     &'** ERROR  : Null space computation requirement'
          WRITE( mpg,'(A)')
     &'** not consistent with factorization options'
         ENDIF
         GOTO 333
        ENDIF
      ENDIF
       IF (icntl(9).NE.1) THEN
         IF (keep(111).NE.0) THEN
          info(1) = -37
          info(2) = 9  
          IF (mpg.GT.0) THEN
           WRITE(mpg,'(A)')
     &'** ERROR  ICNTL(25) incompatible with '
           WRITE( mpg,'(A)')
     &.ne.'** option transposed system (ICNTL(9)1) '
          ENDIF
         ENDIF
         GOTO 333
       ENDIF
      IF (keep(19).EQ.2) THEN
       IF ((keep(111).NE.0).AND.(keep(50).EQ.0)) THEN
         info(1) = -37
         info(2) = 0  
         IF (mpg.GT.0) THEN
          WRITE(mpg,'(A)')
     &'** ERROR  ICNTL(25) incompatible with '
          WRITE( mpg,'(A)')
     &'** option RRQR (ICNLT(56)=2) and unsym. matrices '
         ENDIF
        ENDIF
        GOTO 333
      ENDIF
      IF (keep(111).eq.-1.AND.nrhs.NE.keep(112)+keep(17))THEN
            info(1)=-32
            info(2)=nrhs
            GOTO 333
      ENDIF
      IF (keep(111).gt.0 .AND. nrhs .NE. 1) THEN
            info(1)=-32
            info(2)=nrhs
            GOTO 333
      ENDIF
      IF (keep(248) .NE.0.AND.keep(111).NE.0) THEN
         IF (mpg.GT.0) THEN
            WRITE(mpg,'(A)')
     &           ' ERROR: ICNTL(20) and ICNTL(30) functionalities ',
     &           ' incompatible with null space'
         ENDIF
         info(1) = -37
         IF (keep(237).NE.0) THEN
            info(2) = 30    
            IF (mpg.GT.0) THEN
               WRITE(mpg,'(A)')
     &           ' ERROR: ICNTL(30) functionality ',
     &              ' incompatible with null space'
            ENDIF
         ELSE
            IF (mpg.GT.0) THEN
               WRITE(mpg,'(A)')
     &              ' ERROR: ICNTL(20) functionality ',
     &              ' incompatible with null space'
            ENDIF
            info(2) = 20    
         ENDIF
         GOTO 333
      ENDIF
      IF (( keep(111) .LT. -1 ) .OR.
     &     (keep(111).GT.keep(112)+keep(17)) .OR.
     &     (keep(111) .EQ.-1 .AND. keep(112)+keep(17).EQ.0))
     &     THEN
         info(1)=-36
         info(2)=keep(111)
         GOTO 333
      ENDIF
      IF (keep(221).NE.0.AND.keep(111).NE.0) THEN
         info(1)=-37
         info(2)=26
         GOTO 333
      ENDIF
 333  CONTINUE
      RETURN
      END SUBROUTINE cmumps_get_ns_options_solve
      SUBROUTINE cmumps_rr_init_pointers(id)
      USE cmumps_struc_def
      IMPLICIT NONE
      TYPE (CMUMPS_STRUC) id
      NULLIFY(id%root%QR_TAU)
      NULLIFY(id%root%SVD_U)
      NULLIFY(id%root%SVD_VT)
      NULLIFY(id%root%SINGULAR_VALUES)
      RETURN
      END SUBROUTINE cmumps_rr_init_pointers
      SUBROUTINE cmumps_rr_free_pointers(id)
      USE cmumps_struc_def
      IMPLICIT NONE
      TYPE (CMUMPS_STRUC) id
      IF (associated(id%root%QR_TAU))  THEN
        DEALLOCATE(id%root%QR_TAU)
        NULLIFY(id%root%QR_TAU)
      ENDIF
      IF (associated(id%root%SVD_U))  THEN
        DEALLOCATE(id%root%SVD_U)
        NULLIFY(id%root%SVD_U)
      ENDIF
      IF (associated(id%root%SVD_VT))  THEN
        DEALLOCATE(id%root%SVD_VT)
        NULLIFY(id%root%SVD_VT)
      ENDIF
      IF (associated(id%root%SINGULAR_VALUES))  THEN
        DEALLOCATE(id%root%SINGULAR_VALUES)
        NULLIFY(id%root%SINGULAR_VALUES)
      ENDIF
      RETURN
      END SUBROUTINE cmumps_rr_free_pointers