OpenCMISS-Iron Internal API Documentation
matrix_vector.f90
Go to the documentation of this file.
1 
127 
130 
131  USE base_routines
132  USE constants
133  USE input_output
135  USE kinds
136  USE lists
137  USE strings
138  USE types
140 
141 #include "macros.h"
142 
143  IMPLICIT NONE
144 
145  !PRIVATE
146 
147  !Module parameters
148 
153  INTEGER(INTG), PARAMETER :: matrix_vector_intg_type=integer_type
154  INTEGER(INTG), PARAMETER :: matrix_vector_sp_type=single_real_type
155  INTEGER(INTG), PARAMETER :: matrix_vector_dp_type=double_real_type
156  INTEGER(INTG), PARAMETER :: matrix_vector_l_type=logical_type
158 
163  INTEGER(INTG), PARAMETER :: matrix_block_storage_type=0
164  INTEGER(INTG), PARAMETER :: matrix_diagonal_storage_type=1
165  INTEGER(INTG), PARAMETER :: matrix_column_major_storage_type=2
166  INTEGER(INTG), PARAMETER :: matrix_row_major_storage_type=3
167  INTEGER(INTG), PARAMETER :: matrix_compressed_row_storage_type=4
168  INTEGER(INTG), PARAMETER :: matrix_compressed_column_storage_type=5
169  INTEGER(INTG), PARAMETER :: matrix_row_column_storage_type=6
171 
172  INTEGER(INTG), PARAMETER :: bisectiontolinearsearchthreshold=10
173 
174  !Module types
175 
176  !Matrix types
177 
178  !Module variables
179 
180  INTEGER(INTG), SAVE :: matrix_vector_id=1
181 
182  !Interfaces
183 
185  MODULE PROCEDURE matrix_all_values_set_intg
186  MODULE PROCEDURE matrix_all_values_set_sp
187  MODULE PROCEDURE matrix_all_values_set_dp
188  MODULE PROCEDURE matrix_all_values_set_l
189  END INTERFACE !MATRIX_ALL_VALUES_SET
190 
191  INTERFACE matrix_data_get
192  MODULE PROCEDURE matrix_data_get_intg
193  MODULE PROCEDURE matrix_data_get_sp
194  MODULE PROCEDURE matrix_data_get_dp
195  MODULE PROCEDURE matrix_data_get_l
196  END INTERFACE !MATRIX_DATA_GET
197 
199  MODULE PROCEDURE matrix_values_add_intg
200  MODULE PROCEDURE matrix_values_add_intg1
201  MODULE PROCEDURE matrix_values_add_intg2
202  MODULE PROCEDURE matrix_values_add_sp
203  MODULE PROCEDURE matrix_values_add_sp1
204  MODULE PROCEDURE matrix_values_add_sp2
205  MODULE PROCEDURE matrix_values_add_dp
206  MODULE PROCEDURE matrix_values_add_dp1
207  MODULE PROCEDURE matrix_values_add_dp2
208  MODULE PROCEDURE matrix_values_add_l
209  MODULE PROCEDURE matrix_values_add_l1
210  MODULE PROCEDURE matrix_values_add_l2
211  END INTERFACE !MATRIX_VALUES_ADD
212 
214  MODULE PROCEDURE matrix_values_get_intg
215  MODULE PROCEDURE matrix_values_get_intg1
216  MODULE PROCEDURE matrix_values_get_intg2
217  MODULE PROCEDURE matrix_values_get_sp
218  MODULE PROCEDURE matrix_values_get_sp1
219  MODULE PROCEDURE matrix_values_get_sp2
220  MODULE PROCEDURE matrix_values_get_dp
221  MODULE PROCEDURE matrix_values_get_dp1
222  MODULE PROCEDURE matrix_values_get_dp2
223  MODULE PROCEDURE matrix_values_get_l
224  MODULE PROCEDURE matrix_values_get_l1
225  MODULE PROCEDURE matrix_values_get_l2
226  END INTERFACE !MATRIX_VALUES_GET
227 
229  MODULE PROCEDURE matrix_values_set_intg
230  MODULE PROCEDURE matrix_values_set_intg1
231  MODULE PROCEDURE matrix_values_set_intg2
232  MODULE PROCEDURE matrix_values_set_sp
233  MODULE PROCEDURE matrix_values_set_sp1
234  MODULE PROCEDURE matrix_values_set_sp2
235  MODULE PROCEDURE matrix_values_set_dp
236  MODULE PROCEDURE matrix_values_set_dp1
237  MODULE PROCEDURE matrix_values_set_dp2
238  MODULE PROCEDURE matrix_values_set_l
239  MODULE PROCEDURE matrix_values_set_l1
240  MODULE PROCEDURE matrix_values_set_l2
241  END INTERFACE !MATRIX_VALUES_SET
242 
244  MODULE PROCEDURE vector_all_values_set_intg
245  MODULE PROCEDURE vector_all_values_set_sp
246  MODULE PROCEDURE vector_all_values_set_dp
247  MODULE PROCEDURE vector_all_values_set_l
248  END INTERFACE !VECTOR_ALL_VALUES_SET
249 
250  INTERFACE vector_data_get
251  MODULE PROCEDURE vector_data_get_intg
252  MODULE PROCEDURE vector_data_get_sp
253  MODULE PROCEDURE vector_data_get_dp
254  MODULE PROCEDURE vector_data_get_l
255  END INTERFACE !VECTOR_DATA_GET
256 
258  MODULE PROCEDURE vector_values_get_intg
259  MODULE PROCEDURE vector_values_get_intg1
260  MODULE PROCEDURE vector_values_get_sp
261  MODULE PROCEDURE vector_values_get_sp1
262  MODULE PROCEDURE vector_values_get_dp
263  MODULE PROCEDURE vector_values_get_dp1
264  MODULE PROCEDURE vector_values_get_l
265  MODULE PROCEDURE vector_values_get_l1
266  END INTERFACE !VECTOR_VALUES_GET
267 
269  MODULE PROCEDURE vector_values_set_intg
270  MODULE PROCEDURE vector_values_set_intg1
271  MODULE PROCEDURE vector_values_set_sp
272  MODULE PROCEDURE vector_values_set_sp1
273  MODULE PROCEDURE vector_values_set_dp
274  MODULE PROCEDURE vector_values_set_dp1
275  MODULE PROCEDURE vector_values_set_l
276  MODULE PROCEDURE vector_values_set_l1
277  END INTERFACE !VECTOR_VALUES_SET
278 
280 
283 
288 
291 
293 CONTAINS
294 
295  !
296  !================================================================================================================================
297  !
298 
300  SUBROUTINE matrix_all_values_set_intg(MATRIX,VALUE,ERR,ERROR,*)
302  !Argument variables
303  TYPE(matrix_type), POINTER :: MATRIX
304  INTEGER(INTG), INTENT(IN) :: VALUE
305  INTEGER(INTG), INTENT(OUT) :: ERR
306  TYPE(varying_string), INTENT(OUT) :: ERROR
307  !Local variables
308  TYPE(varying_string) :: LOCAL_ERROR
309 
310  enters("MATRIX_ALL_VALUES_SET_INTG",err,error,*999)
311 
312  IF(ASSOCIATED(matrix)) THEN
313  IF(matrix%MATRIX_FINISHED) THEN
314  IF(matrix%DATA_TYPE==matrix_vector_intg_type) THEN
315  matrix%DATA_INTG=VALUE
316  ELSE
317  local_error="The data type of "//trim(number_to_vstring(matrix%DATA_TYPE,"*",err,error))// &
318  & " does not correspond to the integer data type of the given value."
319  CALL flagerror(local_error,err,error,*999)
320  ENDIF
321  ELSE
322  CALL flagerror("The matrix has not been finished.",err,error,*999)
323  ENDIF
324  ELSE
325  CALL flagerror("Matrix is not associated.",err,error,*999)
326  ENDIF
327 
328  exits("MATRIX_ALL_VALUES_SET_INTG")
329  RETURN
330 999 errorsexits("MATRIX_ALL_VALUES_SET_INTG",err,error)
331  RETURN 1
332  END SUBROUTINE matrix_all_values_set_intg
333 
334  !
335  !================================================================================================================================
336  !
337 
339  SUBROUTINE matrix_all_values_set_sp(MATRIX,VALUE,ERR,ERROR,*)
341  !Argument variables
342  TYPE(matrix_type), POINTER :: MATRIX
343  REAL(SP), INTENT(IN) :: VALUE
344  INTEGER(INTG), INTENT(OUT) :: ERR
345  TYPE(varying_string), INTENT(OUT) :: ERROR
346  !Local variables
347  TYPE(varying_string) :: LOCAL_ERROR
348 
349  enters("MATRIX_ALL_VALUES_SET_SP",err,error,*999)
350 
351  IF(ASSOCIATED(matrix)) THEN
352  IF(matrix%MATRIX_FINISHED) THEN
353  IF(matrix%DATA_TYPE==matrix_vector_sp_type) THEN
354  matrix%DATA_SP=VALUE
355  ELSE
356  local_error="The data type of "//trim(number_to_vstring(matrix%DATA_TYPE,"*",err,error))// &
357  & " does not correspond to the single precision data type of the given value."
358  CALL flagerror(local_error,err,error,*999)
359  ENDIF
360  ELSE
361  CALL flagerror("The matrix has not been finished.",err,error,*999)
362  ENDIF
363  ELSE
364  CALL flagerror("Matrix is not associated.",err,error,*999)
365  ENDIF
366 
367  exits("MATRIX_ALL_VALUES_SET_SP")
368  RETURN
369 999 errorsexits("MATRIX_ALL_VALUES_SET_SP",err,error)
370  RETURN 1
371  END SUBROUTINE matrix_all_values_set_sp
372 
373  !
374  !================================================================================================================================
375  !
376 
378  SUBROUTINE matrix_all_values_set_dp(MATRIX,VALUE,ERR,ERROR,*)
380  !Argument variables
381  TYPE(matrix_type), POINTER :: MATRIX
382  REAL(DP), INTENT(IN) :: VALUE
383  INTEGER(INTG), INTENT(OUT) :: ERR
384  TYPE(varying_string), INTENT(OUT) :: ERROR
385  !Local variables
386  TYPE(varying_string) :: LOCAL_ERROR
387 
388  enters("MATRIX_ALL_VALUES_SET_DP",err,error,*999)
389 
390  IF(ASSOCIATED(matrix)) THEN
391  IF(matrix%MATRIX_FINISHED) THEN
392  IF(matrix%DATA_TYPE==matrix_vector_dp_type) THEN
393  matrix%DATA_DP=VALUE
394  ELSE
395  local_error="The data type of "//trim(number_to_vstring(matrix%DATA_TYPE,"*",err,error))// &
396  & " does not correspond to the double precision data type of the given value."
397  CALL flagerror(local_error,err,error,*999)
398  ENDIF
399  ELSE
400  CALL flagerror("The matrix has not been finished.",err,error,*999)
401  ENDIF
402  ELSE
403  CALL flagerror("Matrix is not associated.",err,error,*999)
404  ENDIF
405 
406  exits("MATRIX_ALL_VALUES_SET_DP")
407  RETURN
408 999 errorsexits("MATRIX_ALL_VALUES_SET_DP",err,error)
409  RETURN 1
410  END SUBROUTINE matrix_all_values_set_dp
411 
412  !
413  !================================================================================================================================
414  !
415 
417  SUBROUTINE matrix_all_values_set_l(MATRIX,VALUE,ERR,ERROR,*)
419  !Argument variables
420  TYPE(matrix_type), POINTER :: MATRIX
421  LOGICAL, INTENT(IN) :: VALUE
422  INTEGER(INTG), INTENT(OUT) :: ERR
423  TYPE(varying_string), INTENT(OUT) :: ERROR
424  !Local variables
425  TYPE(varying_string) :: LOCAL_ERROR
426 
427  enters("MATRIX_ALL_VALUES_SET_L",err,error,*999)
428 
429  IF(ASSOCIATED(matrix)) THEN
430  IF(matrix%MATRIX_FINISHED) THEN
431  IF(matrix%DATA_TYPE==matrix_vector_l_type) THEN
432  matrix%DATA_L=VALUE
433  ELSE
434  local_error="The data type of "//trim(number_to_vstring(matrix%DATA_TYPE,"*",err,error))// &
435  & " does not correspond to the logical data type of the given value."
436  CALL flagerror(local_error,err,error,*999)
437  ENDIF
438  ELSE
439  CALL flagerror("The matrix has not been finished.",err,error,*999)
440  ENDIF
441  ELSE
442  CALL flagerror("Matrix is not associated.",err,error,*999)
443  ENDIF
444 
445  exits("MATRIX_ALL_VALUES_SET_L")
446  RETURN
447 999 errorsexits("MATRIX_ALL_VALUES_SET_L",err,error)
448  RETURN 1
449  END SUBROUTINE matrix_all_values_set_l
450 
451  !
452  !================================================================================================================================
453  !
454 
456  SUBROUTINE matrix_create_finish(MATRIX,ERR,ERROR,*)
458  !Argument variables
459  TYPE(matrix_type), POINTER :: MATRIX
460  INTEGER(INTG), INTENT(OUT) :: ERR
461  TYPE(varying_string), INTENT(OUT) :: ERROR
462  !Local Variables
463  INTEGER(INTG) :: column_idx,COUNT,row_idx,row_idx2
464  TYPE(varying_string) :: LOCAL_ERROR
465 
466  enters("MATRIX_CREATE_FINISH",err,error,*999)
467 
468  IF(ASSOCIATED(matrix)) THEN
469  IF(matrix%MATRIX_FINISHED) THEN
470  CALL flagerror("Matrix has been finished.",err,error,*999)
471  ELSE
472  SELECT CASE(matrix%STORAGE_TYPE)
474  IF(matrix%MAX_M==-1) matrix%MAX_M=matrix%M
475  IF(matrix%MAX_N==-1) matrix%MAX_N=matrix%N
476  matrix%SIZE=matrix%M*matrix%N
477  matrix%NUMBER_NON_ZEROS=matrix%M*matrix%N
478  matrix%MAXIMUM_COLUMN_INDICES_PER_ROW=matrix%N
480  IF(matrix%MAX_M==-1) matrix%MAX_M=matrix%M
481  IF(matrix%MAX_N==-1) matrix%MAX_N=matrix%N
482  matrix%SIZE=matrix%M
483  matrix%NUMBER_NON_ZEROS=matrix%M
484  matrix%MAXIMUM_COLUMN_INDICES_PER_ROW=1
486  IF(matrix%MAX_M==-1) CALL flagerror("Maximum number of rows has not been set for this matrix.",err,error,*999)
487  IF(matrix%MAX_N==-1) CALL flagerror("Maximum number of columns has not been set for this matrix.",err,error,*999)
488  matrix%SIZE=matrix%MAX_M*matrix%N
489  matrix%NUMBER_NON_ZEROS=matrix%M*matrix%N
490  matrix%MAXIMUM_COLUMN_INDICES_PER_ROW=matrix%N
492  IF(matrix%MAX_M==-1) CALL flagerror("Maximum number of rows has not been set for this matrix.",err,error,*999)
493  IF(matrix%MAX_N==-1) CALL flagerror("Maximum number of columns has not been set for this matrix.",err,error,*999)
494  matrix%SIZE=matrix%M*matrix%MAX_N
495  matrix%NUMBER_NON_ZEROS=matrix%M*matrix%N
496  matrix%MAXIMUM_COLUMN_INDICES_PER_ROW=matrix%N
498  IF(matrix%NUMBER_NON_ZEROS==-1) CALL flagerror("Number of non-zeros has not been set for this matrix.",err,error,*999)
499  IF(matrix%MAX_M==-1) matrix%MAX_M=matrix%M
500  IF(matrix%MAX_N==-1) matrix%MAX_N=matrix%N
501  matrix%SIZE=matrix%NUMBER_NON_ZEROS
502  IF(.NOT.ALLOCATED(matrix%COLUMN_INDICES)) &
503  & CALL flagerror("Matrix storage locations column indices have not been set.",err,error,*999)
504  IF(.NOT.ALLOCATED(matrix%ROW_INDICES)) &
505  & CALL flagerror("Matrix storage locations row indices have not been set.",err,error,*999)
506  matrix%MAXIMUM_COLUMN_INDICES_PER_ROW=0
507  DO row_idx=1,matrix%M
508  IF((matrix%ROW_INDICES(row_idx+1)-matrix%ROW_INDICES(row_idx))>matrix%MAXIMUM_COLUMN_INDICES_PER_ROW) &
509  & matrix%MAXIMUM_COLUMN_INDICES_PER_ROW=matrix%ROW_INDICES(row_idx+1)-matrix%ROW_INDICES(row_idx)
510  ENDDO !row_idx
512  IF(matrix%NUMBER_NON_ZEROS==-1) CALL flagerror("Number of non-zeros has not been set for this matrix.",err,error,*999)
513  IF(matrix%MAX_M==-1) matrix%MAX_M=matrix%M
514  IF(matrix%MAX_N==-1) matrix%MAX_N=matrix%N
515  matrix%SIZE=matrix%NUMBER_NON_ZEROS
516  IF(.NOT.ALLOCATED(matrix%COLUMN_INDICES)) &
517  & CALL flagerror("Matrix storage locations column indices have not been set.",err,error,*999)
518  IF(.NOT.ALLOCATED(matrix%ROW_INDICES)) &
519  & CALL flagerror("Matrix storage locations row indices have not been set.",err,error,*999)
520  matrix%MAXIMUM_COLUMN_INDICES_PER_ROW=0
521  DO row_idx=1,matrix%M
522  count=0
523  DO column_idx=1,matrix%N
524  DO row_idx2=matrix%COLUMN_INDICES(column_idx),matrix%COLUMN_INDICES(column_idx+1)-1
525  IF(matrix%ROW_INDICES(row_idx2)==row_idx) count=count+1
526  ENDDO !row_idx2
527  ENDDO !column_idx
528  IF(count>matrix%MAXIMUM_COLUMN_INDICES_PER_ROW) matrix%MAXIMUM_COLUMN_INDICES_PER_ROW=count
529  ENDDO !row_idx
531  IF(matrix%NUMBER_NON_ZEROS==-1) CALL flagerror("Number of non-zeros has not been set for this matrix.",err,error,*999)
532  IF(matrix%MAX_M==-1) matrix%MAX_M=matrix%M
533  IF(matrix%MAX_N==-1) matrix%MAX_N=matrix%N
534  matrix%SIZE=matrix%NUMBER_NON_ZEROS
535  IF(.NOT.ALLOCATED(matrix%COLUMN_INDICES)) &
536  & CALL flagerror("Matrix storage locations column indices have not been set.",err,error,*999)
537  IF(.NOT.ALLOCATED(matrix%ROW_INDICES)) &
538  & CALL flagerror("Matrix storage locations row indices have not been set.",err,error,*999)
539  matrix%MAXIMUM_COLUMN_INDICES_PER_ROW=0
540  DO row_idx=1,matrix%M
541  count=0
542  DO row_idx2=1,matrix%NUMBER_NON_ZEROS
543  IF(matrix%ROW_INDICES(row_idx2)==row_idx) count=count+1
544  ENDDO !row_idx2
545  IF(count>matrix%MAXIMUM_COLUMN_INDICES_PER_ROW) matrix%MAXIMUM_COLUMN_INDICES_PER_ROW=count
546  ENDDO !row_idx
547  CASE DEFAULT
548  local_error="The matrix storage type of "//trim(number_to_vstring(matrix%STORAGE_TYPE,"*",err,error))//" is invalid."
549  CALL flagerror(local_error,err,error,*999)
550  END SELECT
551  IF(matrix%SIZE>0) THEN
552  SELECT CASE(matrix%DATA_TYPE)
554  ALLOCATE(matrix%DATA_INTG(matrix%SIZE),stat=err)
555  IF(err/=0) CALL flagerror("Could not allocate matrix integer data.",err,error,*999)
557  ALLOCATE(matrix%DATA_SP(matrix%SIZE),stat=err)
558  IF(err/=0) CALL flagerror("Could not allocate matrix single precision data.",err,error,*999)
560  ALLOCATE(matrix%DATA_DP(matrix%SIZE),stat=err)
561  IF(err/=0) CALL flagerror("Could not allocate matrix double precision data.",err,error,*999)
563  ALLOCATE(matrix%DATA_L(matrix%SIZE),stat=err)
564  IF(err/=0) CALL flagerror("Could not allocate matrix logical data.",err,error,*999)
565  CASE DEFAULT
566  local_error="The matrix data type of "//trim(number_to_vstring(matrix%DATA_TYPE,"*",err,error))//" is invalid."
567  CALL flagerror(local_error,err,error,*999)
568  END SELECT
569  ENDIF
570  matrix%ID=matrix_vector_id
572  matrix%MATRIX_FINISHED=.true.
573  ENDIF
574  ELSE
575  CALL flagerror("Matrix is not associated.",err,error,*999)
576  ENDIF
577 
578  exits("MATRIX_CREATE_FINISH")
579  RETURN
580 !!TODO: deallocate on error
581 999 errorsexits("MATRIX_CREATE_FINISH",err,error)
582  RETURN 1
583  END SUBROUTINE matrix_create_finish
584 
585  !
586  !================================================================================================================================
587  !
588 
590  SUBROUTINE matrix_create_start(MATRIX,ERR,ERROR,*)
592  !Argument variables
593  TYPE(matrix_type), POINTER :: MATRIX
594  INTEGER(INTG), INTENT(OUT) :: ERR
595  TYPE(varying_string), INTENT(OUT) :: ERROR
596  !Local Variables
597 
598  enters("MATRIX_CREATE_START",err,error,*999)
599 
600  IF(ASSOCIATED(matrix)) THEN
601  CALL flagerror("Matrix is already associated.",err,error,*998)
602  ELSE
603  ALLOCATE(matrix,stat=err)
604  IF(err/=0) CALL flagerror("Could not allocate the matrix.",err,error,*999)
605  CALL matrix_initialise(matrix,err,error,*999)
606  !Set the defaults
607  matrix%DATA_TYPE=matrix_vector_dp_type
608  matrix%STORAGE_TYPE=matrix_block_storage_type
609  ENDIF
610 
611  exits("MATRIX_CREATE_START")
612  RETURN
613 999 IF(ASSOCIATED(matrix)) CALL matrix_finalise(matrix,err,error,*998)
614 998 errorsexits("MATRIX_CREATE_START",err,error)
615  RETURN 1
616  END SUBROUTINE matrix_create_start
617 
618  !
619  !================================================================================================================================
620  !
621 
623  SUBROUTINE matrix_data_get_intg(MATRIX,DATA,ERR,ERROR,*)
625  !Argument variables
626  TYPE(matrix_type), POINTER :: MATRIX
627  INTEGER(INTG), POINTER :: DATA(:)
628  INTEGER(INTG), INTENT(OUT) :: ERR
629  TYPE(varying_string), INTENT(OUT) :: ERROR
630  !Local Variables
631  TYPE(varying_string) :: LOCAL_ERROR
632 
633  enters("MATRIX_DATA_GET_INTG",err,error,*999)
634 
635  IF(ASSOCIATED(matrix)) THEN
636  IF(ASSOCIATED(data)) THEN
637  CALL flagerror("Data is already associated.",err,error,*999)
638  ELSE
639  NULLIFY(data)
640  IF(matrix%MATRIX_FINISHED) THEN
641  IF(matrix%DATA_TYPE==matrix_vector_intg_type) THEN
642  data=>matrix%DATA_INTG
643  ELSE
644  local_error="The data type of "//trim(number_to_vstring(matrix%DATA_TYPE,"*",err,error))// &
645  & " does not correspond to the integer data type of the requested values."
646  CALL flagerror(local_error,err,error,*999)
647  ENDIF
648  ELSE
649  CALL flagerror("The matrix has not been finished.",err,error,*999)
650  ENDIF
651  ENDIF
652  ELSE
653  CALL flagerror("Matrix is not associated.",err,error,*999)
654  ENDIF
655 
656  exits("MATRIX_DATA_GET_INTG")
657  RETURN
658 999 errorsexits("MATRIX_DATA_GET_INTG",err,error)
659  RETURN 1
660  END SUBROUTINE matrix_data_get_intg
661 
662  !
663  !================================================================================================================================
664  !
665 
667  SUBROUTINE matrix_data_get_sp(MATRIX,DATA,ERR,ERROR,*)
669  !Argument variables
670  TYPE(matrix_type), POINTER :: MATRIX
671  REAL(SP), POINTER :: DATA(:)
672  INTEGER(INTG), INTENT(OUT) :: ERR
673  TYPE(varying_string), INTENT(OUT) :: ERROR
674  !Local Variables
675  TYPE(varying_string) :: LOCAL_ERROR
676 
677  enters("MATRIX_DATA_GET_SP",err,error,*999)
678 
679  IF(ASSOCIATED(matrix)) THEN
680  IF(ASSOCIATED(data)) THEN
681  CALL flagerror("Data is already associated.",err,error,*999)
682  ELSE
683  NULLIFY(data)
684  IF(matrix%MATRIX_FINISHED) THEN
685  IF(matrix%DATA_TYPE==matrix_vector_sp_type) THEN
686  data=>matrix%DATA_SP
687  ELSE
688  local_error="The data type of "//trim(number_to_vstring(matrix%DATA_TYPE,"*",err,error))// &
689  & " does not correspond to the single precision data type of the requested values."
690  CALL flagerror(local_error,err,error,*999)
691  ENDIF
692  ELSE
693  CALL flagerror("The matrix has not been finished.",err,error,*999)
694  ENDIF
695  ENDIF
696  ELSE
697  CALL flagerror("Matrix is not associated.",err,error,*999)
698  ENDIF
699 
700  exits("MATRIX_DATA_GET_SP")
701  RETURN
702 999 errorsexits("MATRIX_DATA_GET_SP",err,error)
703  RETURN 1
704  END SUBROUTINE matrix_data_get_sp
705 
706  !
707  !================================================================================================================================
708  !
709 
711  SUBROUTINE matrix_data_get_dp(MATRIX,DATA,ERR,ERROR,*)
713  !Argument variables
714  TYPE(matrix_type), POINTER :: MATRIX
715  REAL(DP), POINTER :: DATA(:)
716  INTEGER(INTG), INTENT(OUT) :: ERR
717  TYPE(varying_string), INTENT(OUT) :: ERROR
718  !Local Variables
719  TYPE(varying_string) :: LOCAL_ERROR
720 
721  enters("MATRIX_DATA_GET_DP",err,error,*999)
722 
723  IF(ASSOCIATED(matrix)) THEN
724  IF(ASSOCIATED(data)) THEN
725  CALL flagerror("Data is already associated.",err,error,*999)
726  ELSE
727  NULLIFY(data)
728  IF(matrix%MATRIX_FINISHED) THEN
729  IF(matrix%DATA_TYPE==matrix_vector_dp_type) THEN
730  data=>matrix%DATA_DP
731  ELSE
732  local_error="The data type of "//trim(number_to_vstring(matrix%DATA_TYPE,"*",err,error))// &
733  & " does not correspond to the double precision data type of the requested values."
734  CALL flagerror(local_error,err,error,*999)
735  ENDIF
736  ELSE
737  CALL flagerror("The matrix has not been finished.",err,error,*999)
738  ENDIF
739  ENDIF
740  ELSE
741  CALL flagerror("Matrix is not associated.",err,error,*999)
742  ENDIF
743 
744  exits("MATRIX_DATA_GET_DP")
745  RETURN
746 999 errorsexits("MATRIX_DATA_GET_DP",err,error)
747  RETURN 1
748  END SUBROUTINE matrix_data_get_dp
749 
750  !
751  !================================================================================================================================
752  !
753 
755  SUBROUTINE matrix_data_get_l(MATRIX,DATA,ERR,ERROR,*)
757  !Argument variables
758  TYPE(matrix_type), POINTER :: MATRIX
759  LOGICAL, POINTER :: DATA(:)
760  INTEGER(INTG), INTENT(OUT) :: ERR
761  TYPE(varying_string), INTENT(OUT) :: ERROR
762  !Local Variables
763  TYPE(varying_string) :: LOCAL_ERROR
764 
765  enters("MATRIX_DATA_GET_L",err,error,*999)
766 
767  IF(ASSOCIATED(matrix)) THEN
768  IF(ASSOCIATED(data)) THEN
769  CALL flagerror("Data is already associated.",err,error,*999)
770  ELSE
771  NULLIFY(data)
772  IF(matrix%MATRIX_FINISHED) THEN
773  IF(matrix%DATA_TYPE==matrix_vector_l_type) THEN
774  data=>matrix%DATA_L
775  ELSE
776  local_error="The data type of "//trim(number_to_vstring(matrix%DATA_TYPE,"*",err,error))// &
777  & " does not correspond to the logical data type of the requested values."
778  CALL flagerror(local_error,err,error,*999)
779  ENDIF
780  ELSE
781  CALL flagerror("The matrix has not been finished.",err,error,*999)
782  ENDIF
783  ENDIF
784  ELSE
785  CALL flagerror("Matrix is not associated.",err,error,*999)
786  ENDIF
787 
788  exits("MATRIX_DATA_GET_L")
789  RETURN
790 999 errorsexits("MATRIX_DATA_GET_L",err,error)
791  RETURN 1
792  END SUBROUTINE matrix_data_get_l
793 
794  !
795  !================================================================================================================================
796  !
797 
799  SUBROUTINE matrix_datatypeget(matrix,dataType,err,error,*)
801  !Argument variables
802  TYPE(matrix_type), POINTER :: matrix
803  INTEGER(INTG), INTENT(OUT) :: dataType
804  INTEGER(INTG), INTENT(OUT) :: err
805  TYPE(varying_string), INTENT(OUT) :: error
806 
807  enters("Matrix_DataTypeGet",err,error,*999)
808 
809  IF(ASSOCIATED(matrix)) THEN
810  IF(.NOT.matrix%matrix_finished) THEN
811  CALL flag_error("The matrix has not been finished.",err,error,*999)
812  ELSE
813  datatype=matrix%data_type
814  END IF
815  ELSE
816  CALL flag_error("Matrix is not associated.",err,error,*999)
817  END IF
818 
819  exits("Matrix_DataTypeGet")
820  RETURN
821 999 errorsexits("Matrix_DataTypeGet",err,error)
822  RETURN 1
823  END SUBROUTINE matrix_datatypeget
824 
825  !
826  !================================================================================================================================
827  !
828 
830  SUBROUTINE matrix_data_type_set(MATRIX,DATA_TYPE,ERR,ERROR,*)
832  !Argument variables
833  TYPE(matrix_type), POINTER :: MATRIX
834  INTEGER(INTG), INTENT(IN) :: DATA_TYPE
835  INTEGER(INTG), INTENT(OUT) :: ERR
836  TYPE(varying_string), INTENT(OUT) :: ERROR
837  !Local Variables
838  TYPE(varying_string) :: LOCAL_ERROR
839 
840  enters("MATRIX_DATA_TYPE_SET",err,error,*999)
841 
842  IF(ASSOCIATED(matrix)) THEN
843  IF(matrix%MATRIX_FINISHED) THEN
844  CALL flagerror("The matrix has been finished.",err,error,*999)
845  ELSE
846  SELECT CASE(data_type)
848  matrix%DATA_TYPE=matrix_vector_intg_type
850  matrix%DATA_TYPE=matrix_vector_sp_type
852  matrix%DATA_TYPE=matrix_vector_dp_type
854  matrix%DATA_TYPE=matrix_vector_l_type
855  CASE DEFAULT
856  local_error="The matrix vector data type of "//trim(number_to_vstring(data_type,"*",err,error))//" is invalid."
857  CALL flagerror(local_error,err,error,*999)
858  END SELECT
859  ENDIF
860  ELSE
861  CALL flagerror("Matrix is not associated.",err,error,*999)
862  ENDIF
863 
864  exits("MATRIX_DATA_TYPE_SET")
865  RETURN
866 999 errorsexits("MATRIX_DATA_TYPE_SET",err,error)
867  RETURN 1
868  END SUBROUTINE matrix_data_type_set
869 
870  !
871  !================================================================================================================================
872  !
873 
875  SUBROUTINE matrix_destroy(MATRIX,ERR,ERROR,*)
877  !Argument variables
878  TYPE(matrix_type), POINTER :: MATRIX
879  INTEGER(INTG), INTENT(OUT) :: ERR
880  TYPE(varying_string), INTENT(OUT) :: ERROR
881 
882  enters("MATRIX_DESTROY",err,error,*999)
883 
884  IF(ASSOCIATED(matrix)) THEN
885  CALL matrix_finalise(matrix,err,error,*999)
886  ELSE
887  CALL flagerror("Matrix is not associated.",err,error,*999)
888  ENDIF
889 
890  exits("MATRIX_DESTROY")
891  RETURN
892 999 errorsexits("MATRIX_DESTROY",err,error)
893  RETURN 1
894  END SUBROUTINE matrix_destroy
895 
896  !
897  !================================================================================================================================
898  !
899 
901  SUBROUTINE matrix_duplicate(MATRIX,NEW_MATRIX,ERR,ERROR,*)
903  !Argument variables
904  TYPE(matrix_type), POINTER :: MATRIX
905  TYPE(matrix_type), POINTER :: NEW_MATRIX
906  INTEGER(INTG), INTENT(OUT) :: ERR
907  TYPE(varying_string), INTENT(OUT) :: ERROR
908  !Local Variables
909  TYPE(varying_string) :: LOCAL_ERROR
910 
911  enters("MATRIX_DUPLICATE",err,error,*998)
912 
913  IF(ASSOCIATED(matrix)) THEN
914  IF(ASSOCIATED(new_matrix)) THEN
915  CALL flagerror("New matrix is already associated.",err,error,*998)
916  ELSE
917  CALL matrix_create_start(new_matrix,err,error,*999)
918  CALL matrix_data_type_set(new_matrix,matrix%DATA_TYPE,err,error,*999)
919  CALL matrix_size_set(new_matrix,matrix%M,matrix%N,err,error,*999)
920  CALL matrix_storage_type_set(new_matrix,matrix%STORAGE_TYPE,err,error,*999)
921  SELECT CASE(matrix%STORAGE_TYPE)
923  !Do nothing
925  CALL matrix_max_size_set(new_matrix,matrix%MAX_M,matrix%MAX_N,err,error,*999)
927  CALL matrix_number_non_zeros_set(new_matrix,matrix%NUMBER_NON_ZEROS,err,error,*999)
928  CALL matrix_storage_locations_set(new_matrix,matrix%ROW_INDICES,matrix%COLUMN_INDICES,err,error,*999)
929  CASE DEFAULT
930  local_error="The matrix storage type of "//trim(number_to_vstring(matrix%STORAGE_TYPE,"*",err,error))//" is invalid."
931  CALL flagerror(local_error,err,error,*999)
932  END SELECT
933  CALL matrix_create_finish(new_matrix,err,error,*999)
934  ENDIF
935  ELSE
936  CALL flagerror("Matrix is not associated.",err,error,*998)
937  ENDIF
938 
939  exits("MATRIX_DUPLICATE")
940  RETURN
941 999 CALL matrix_finalise(new_matrix,err,error,*998)
942 998 errorsexits("MATRIX_DUPLICATE",err,error)
943  RETURN 1
944  END SUBROUTINE matrix_duplicate
945 
946  !
947  !================================================================================================================================
948  !
949 
951  SUBROUTINE matrix_finalise(MATRIX,ERR,ERROR,*)
953  !Argument variables
954  TYPE(matrix_type), POINTER :: MATRIX
955  INTEGER(INTG), INTENT(OUT) :: ERR
956  TYPE(varying_string), INTENT(OUT) :: ERROR
957  !Local Variables
958 
959  enters("MATRIX_FINALISE",err,error,*999)
960 
961  IF(ASSOCIATED(matrix)) THEN
962  IF(ALLOCATED(matrix%ROW_INDICES)) DEALLOCATE(matrix%ROW_INDICES)
963  IF(ALLOCATED(matrix%COLUMN_INDICES)) DEALLOCATE(matrix%COLUMN_INDICES)
964  IF(ALLOCATED(matrix%DATA_INTG)) DEALLOCATE(matrix%DATA_INTG)
965  IF(ALLOCATED(matrix%DATA_SP)) DEALLOCATE(matrix%DATA_SP)
966  IF(ALLOCATED(matrix%DATA_DP)) DEALLOCATE(matrix%DATA_DP)
967  IF(ALLOCATED(matrix%DATA_L)) DEALLOCATE(matrix%DATA_L)
968  DEALLOCATE(matrix)
969  ENDIF
970 
971  exits("MATRIX_FINALISE")
972  RETURN
973 999 errorsexits("MATRIX_FINALISE",err,error)
974  RETURN 1
975  END SUBROUTINE matrix_finalise
976 
977  !
978  !================================================================================================================================
979  !
980 
982  SUBROUTINE matrix_initialise(MATRIX,ERR,ERROR,*)
984  !Argument variables
985  TYPE(matrix_type), POINTER :: MATRIX
986  INTEGER(INTG), INTENT(OUT) :: ERR
987  TYPE(varying_string), INTENT(OUT) :: ERROR
988  !Local Variables
989 
990  enters("MATRIX_INITIALISE",err,error,*999)
991 
992  IF(ASSOCIATED(matrix)) THEN
993  !!TODO: have a matrix user number etc.
994  matrix%ID=0
995  matrix%MATRIX_FINISHED=.false.
996  matrix%M=0
997  matrix%N=0
998  matrix%MAX_M=-1
999  matrix%MAX_N=-1
1000  matrix%DATA_TYPE=0
1001  matrix%STORAGE_TYPE=0
1002  matrix%NUMBER_NON_ZEROS=0
1003  matrix%SIZE=0
1004  matrix%MAXIMUM_COLUMN_INDICES_PER_ROW=0
1005  ELSE
1006  CALL flagerror("Matrix is not associated.",err,error,*999)
1007  ENDIF
1008 
1009  exits("MATRIX_INITIALISE")
1010  RETURN
1011 999 errorsexits("MATRIX_INITIALISE",err,error)
1012  RETURN 1
1013  END SUBROUTINE matrix_initialise
1014 
1015  !
1016  !================================================================================================================================
1017  !
1018 
1020  SUBROUTINE matrix_max_columns_per_row_get(MATRIX,MAX_COLUMNS_PER_ROW,ERR,ERROR,*)
1022  !Argument variables
1023  TYPE(matrix_type), POINTER :: MATRIX
1024  INTEGER(INTG), INTENT(OUT) :: MAX_COLUMNS_PER_ROW
1025  INTEGER(INTG), INTENT(OUT) :: ERR
1026  TYPE(varying_string), INTENT(OUT) :: ERROR
1027  !Local Variables
1028 
1029  enters("MATRIX_MAX_COLUMNS_PER_ROW_GET",err,error,*999)
1030 
1031  IF(ASSOCIATED(matrix)) THEN
1032  IF(matrix%MATRIX_FINISHED) THEN
1033  max_columns_per_row=matrix%MAXIMUM_COLUMN_INDICES_PER_ROW
1034  ELSE
1035  CALL flagerror("The matrix has not been finished.",err,error,*999)
1036  ENDIF
1037  ELSE
1038  CALL flagerror("Matrix is not associated.",err,error,*999)
1039  ENDIF
1040 
1041  exits("MATRIX_MAX_COLUMNS_PER_ROW_GET")
1042  RETURN
1043 999 errorsexits("MATRIX_MAX_COLUMNS_PER_ROW_GET",err,error)
1044  RETURN 1
1045  END SUBROUTINE matrix_max_columns_per_row_get
1046 
1047  !
1048  !================================================================================================================================
1049  !
1050 
1052  SUBROUTINE matrix_number_non_zeros_set(MATRIX,NUMBER_NON_ZEROS,ERR,ERROR,*)
1054  !Argument variables
1055  TYPE(matrix_type), POINTER :: MATRIX
1056  INTEGER(INTG), INTENT(IN) :: NUMBER_NON_ZEROS
1057  INTEGER(INTG), INTENT(OUT) :: ERR
1058  TYPE(varying_string), INTENT(OUT) :: ERROR
1059  !Local Variables
1060  TYPE(varying_string) :: LOCAL_ERROR
1061 
1062  enters("MATRIX_NUMBER_NON_ZEROS_SET",err,error,*999)
1063 
1064  IF(ASSOCIATED(matrix)) THEN
1065  IF(matrix%MATRIX_FINISHED) THEN
1066  CALL flagerror("The matrix has already been finished.",err,error,*999)
1067  ELSE
1068  SELECT CASE(matrix%STORAGE_TYPE)
1070  CALL flagerror("Can not set the number of non-zeros for a matrix with block storage.",err,error,*999)
1072  CALL flagerror("Can not set the number of non-zeros for a matrix with diagonal storage.",err,error,*999)
1074  CALL flagerror("Can not set the number of non-zeros for a matrix with column major storage.",err,error,*999)
1076  CALL flagerror("Can not set the number of non-zeros for a matrix with row major storage.",err,error,*999)
1078  IF(number_non_zeros>=0) THEN
1079  matrix%NUMBER_NON_ZEROS=number_non_zeros
1080  ELSE
1081  local_error="The number of non-zeros ("//trim(number_to_vstring(number_non_zeros,"*",err,error))// &
1082  & ") is invalid. The number must be greater than or equal to zero."
1083  CALL flagerror(local_error,err,error,*999)
1084  ENDIF
1085  CASE DEFAULT
1086  local_error="The matrix storage type of "//trim(number_to_vstring(matrix%STORAGE_TYPE,"*",err,error))//" is invalid."
1087  CALL flagerror(local_error,err,error,*999)
1088  END SELECT
1089  ENDIF
1090  ELSE
1091  CALL flagerror("Matrix is not associated.",err,error,*999)
1092  ENDIF
1093 
1094  exits("MATRIX_NUMBER_NON_ZEROS_SET")
1095  RETURN
1096 999 errorsexits("MATRIX_NUMBER_NON_ZEROS_SET",err,error)
1097  RETURN 1
1098  END SUBROUTINE matrix_number_non_zeros_set
1099 
1100  !
1101  !================================================================================================================================
1102  !
1103 
1105  SUBROUTINE matrix_number_non_zeros_get(MATRIX,NUMBER_NON_ZEROS,ERR,ERROR,*)
1107  !Argument variables
1108  TYPE(matrix_type), POINTER :: MATRIX
1109  INTEGER(INTG), INTENT(OUT) :: NUMBER_NON_ZEROS
1110  INTEGER(INTG), INTENT(OUT) :: ERR
1111  TYPE(varying_string), INTENT(OUT) :: ERROR
1112  !Local Variables
1113  TYPE(varying_string) :: LOCAL_ERROR
1114 
1115  enters("MATRIX_NUMBER_NON_ZEROS_GET",err,error,*999)
1116 
1117  IF(ASSOCIATED(matrix)) THEN
1118  IF(matrix%MATRIX_FINISHED) THEN
1119  SELECT CASE(matrix%STORAGE_TYPE)
1123  number_non_zeros=matrix%NUMBER_NON_ZEROS
1124  CASE DEFAULT
1125  local_error="The matrix storage type of "//trim(number_to_vstring(matrix%STORAGE_TYPE,"*",err,error))//" is invalid."
1126  CALL flagerror(local_error,err,error,*999)
1127  END SELECT
1128  ELSE
1129  CALL flagerror("The matrix is not finished.",err,error,*999)
1130  ENDIF
1131  ELSE
1132  CALL flagerror("Matrix is not associated.",err,error,*999)
1133  ENDIF
1134 
1135  exits("MATRIX_NUMBER_NON_ZEROS_GET")
1136  RETURN
1137 999 errorsexits("MATRIX_NUMBER_NON_ZEROS_GET",err,error)
1138  RETURN 1
1139  END SUBROUTINE matrix_number_non_zeros_get
1140 
1141  !
1142  !================================================================================================================================
1143  !
1145  SUBROUTINE matrix_linklist_set(MATRIX,LIST,ERR,ERROR,*)
1147  !Argument variables
1148  TYPE(matrix_type), POINTER :: MATRIX
1149  TYPE(linkedlist),pointer :: LIST(:)
1150  INTEGER(INTG), INTENT(OUT) :: ERR
1151  TYPE(varying_string), INTENT(OUT) :: ERROR
1152  !Local Variables
1153 
1154  enters("MATRIX_LINKLIST_SET",err,error,*999)
1155 
1156  IF(ASSOCIATED(matrix)) THEN
1157  IF(matrix%MATRIX_FINISHED) THEN
1158  CALL flagerror("The matrix has been finished",err,error,*999)
1159  ELSE
1160  matrix%LIST => list
1161  ENDIF
1162  ELSE
1163  CALL flagerror("Matrix is not associated.",err,error,*999)
1164  ENDIF
1165 
1166  exits("MATRIX_LINKLIST_SET")
1167  RETURN
1168 999 errorsexits("MATRIX_LINKLIST_SET",err,error)
1169  RETURN 1
1170  END SUBROUTINE matrix_linklist_set
1171 
1172  !
1173  !================================================================================================================================
1174  !!>Gets the maximum number of columns in each row of a distributed matrix.
1175  SUBROUTINE matrix_linklist_get(MATRIX,LIST,ERR,ERROR,*)
1177  !Argument variables
1178  TYPE(matrix_type), POINTER :: MATRIX
1179  type(linkedlist),pointer :: list(:)
1180  INTEGER(INTG), INTENT(OUT) :: ERR
1181  TYPE(varying_string), INTENT(OUT) :: ERROR
1182  !Local Variables
1183 
1184  enters("MATRIX_LINKLIST_GET",err,error,*999)
1185 
1186  IF(ASSOCIATED(matrix)) THEN
1187  IF(matrix%MATRIX_FINISHED) THEN
1188  list=>matrix%LIST
1189  ELSE
1190  CALL flagerror("The matrix has not been finished",err,error,*999)
1191  ENDIF
1192  ELSE
1193  CALL flagerror("Matrix is not associated.",err,error,*999)
1194  ENDIF
1195 
1196  exits("MATRIX_LINKLIST_GET")
1197  RETURN
1198 999 errorsexits("MATRIX_LINKLIST_GET",err,error)
1199  RETURN 1
1200  END SUBROUTINE matrix_linklist_get
1201 
1202  !
1203  !================================================================================================================================
1204  !
1205  !
1207  SUBROUTINE matrix_max_size_set(MATRIX,MAX_M,MAX_N,ERR,ERROR,*)
1209  !Argument variables
1210  TYPE(matrix_type), POINTER :: MATRIX
1211  INTEGER(INTG), INTENT(IN) :: MAX_M
1212  INTEGER(INTG), INTENT(IN) :: MAX_N
1213  INTEGER(INTG), INTENT(OUT) :: ERR
1214  TYPE(varying_string), INTENT(OUT) :: ERROR
1215  !Local Variables
1216  TYPE(varying_string) :: LOCAL_ERROR
1217 
1218  enters("MATRIX_MAX_SIZE_SET",err,error,*999)
1219 
1220  IF(ASSOCIATED(matrix)) THEN
1221  IF(matrix%MATRIX_FINISHED) THEN
1222  CALL flagerror("The matrix has been finished.",err,error,*999)
1223  ELSE
1224  IF(max_m>0) THEN
1225  IF(max_n>0) THEN
1226  IF(max_m>=matrix%M) THEN
1227  IF(max_n>=matrix%N) THEN
1228  matrix%MAX_M=max_m
1229  matrix%MAX_N=max_n
1230  ELSE
1231  local_error="The maximum number of matrix rows ("//trim(number_to_vstring(max_n,"*",err,error))// &
1232  & ") must be >= the number of matrix rows ("//trim(number_to_vstring(matrix%N,"*",err,error))//")."
1233  CALL flagerror(local_error,err,error,*999)
1234  ENDIF
1235  ELSE
1236  local_error="The maximum number of matrix columns ("//trim(number_to_vstring(max_m,"*",err,error))// &
1237  & ") must be >= the number of matrix columns ("//trim(number_to_vstring(matrix%M,"*",err,error))//")."
1238  CALL flagerror(local_error,err,error,*999)
1239  ENDIF
1240  ELSE
1241  local_error="The maximum number of matrix columns of "//trim(number_to_vstring(max_n,"*",err,error))// &
1242  & " is invalid. The number must be > 0."
1243  CALL flagerror(local_error,err,error,*999)
1244  ENDIF
1245  ELSE
1246  local_error="The maximum number of matrix rows of "//trim(number_to_vstring(max_m,"*",err,error))// &
1247  & " is invalid. The number must be > 0."
1248  CALL flagerror(local_error,err,error,*999)
1249  ENDIF
1250  ENDIF
1251  ELSE
1252  CALL flagerror("Matrix is not associated.",err,error,*999)
1253  ENDIF
1254 
1255  exits("MATRIX_MAX_SIZE_SET")
1256  RETURN
1257 999 errorsexits("MATRIX_MAX_SIZE_SET",err,error)
1258  RETURN 1
1259  END SUBROUTINE matrix_max_size_set
1260 
1261  !
1262  !================================================================================================================================
1263  !
1264 
1266  SUBROUTINE matrix_output(ID,MATRIX,ERR,ERROR,*)
1268  !Argument variables
1269  INTEGER(INTG), INTENT(IN) :: ID
1270  TYPE(matrix_type), POINTER :: MATRIX
1271  INTEGER(INTG), INTENT(OUT) :: ERR
1272  TYPE(varying_string), INTENT(OUT) :: ERROR
1273  !Local Variables
1274  INTEGER(INTG) :: i,j
1275  CHARACTER(LEN=9) :: ROW_STRING,COL_STRING
1276  CHARACTER(LEN=39) :: INITIAL_STRING
1277  TYPE(varying_string) :: LOCAL_ERROR
1278 
1279  enters("MATRIX_OUTPUT",err,error,*999)
1280 
1281  IF(ASSOCIATED(matrix)) THEN
1282  IF(matrix%MATRIX_FINISHED) THEN
1283  SELECT CASE(matrix%STORAGE_TYPE)
1285  SELECT CASE(matrix%DATA_TYPE)
1287  CALL write_string_matrix(id,1,1,matrix%M,1,1,matrix%N,8,8,reshape(matrix%DATA_INTG,(/matrix%MAX_M,matrix%MAX_N/)), &
1288  & write_string_matrix_name_and_indices,'("Matrix','(",I9,",:)',':",8(X,I13))','(20X,8(X,I13))', &
1289  & err,error,*999)
1290  CASE(matrix_vector_sp_type)
1291  CALL write_string_matrix(id,1,1,matrix%M,1,1,matrix%N,8,8,reshape(matrix%DATA_SP,(/matrix%MAX_M,matrix%MAX_N/)), &
1292  & write_string_matrix_name_and_indices,'("Matrix','(",I9,",:)',':",8(X,E13.6))','(20X,8(X,E13.6))', &
1293  & err,error,*999)
1294  CASE(matrix_vector_dp_type)
1295  CALL write_string_matrix(id,1,1,matrix%M,1,1,matrix%N,8,8,reshape(matrix%DATA_DP,(/matrix%MAX_M,matrix%MAX_N/)), &
1296  & write_string_matrix_name_and_indices,'("Matrix','(",I9,",:)',':",8(X,E13.6))','(20X,8(X,E13.6))', &
1297  & err,error,*999)
1298  CASE(matrix_vector_l_type)
1299  CALL write_string_matrix(id,1,1,matrix%M,1,1,matrix%N,8,8,reshape(matrix%DATA_L,(/matrix%MAX_M,matrix%MAX_N/)), &
1300  & write_string_matrix_name_and_indices,'("Matrix','(",I9,",:)',':",8(X,L13))','(20X,8(X,L13))', &
1301  & err,error,*999)
1302  CASE DEFAULT
1303  local_error="The matrix data type of "//trim(number_to_vstring(matrix%DATA_TYPE,"*",err,error))//" is invalid."
1304  CALL flagerror(local_error,err,error,*999)
1305  END SELECT
1307  CALL flagerror("Not implemented.",err,error,*999)
1309  CALL flagerror("Not implemented.",err,error,*999)
1311  CALL flagerror("Not implemented.",err,error,*999)
1313  DO i=1,matrix%M
1314  row_string=number_to_character(i,"I9",err,error)
1315  SELECT CASE(matrix%DATA_TYPE)
1317  initial_string='("Matrix('//row_string//',:):",8(X,I13))'
1318  CALL write_string_vector(id,matrix%ROW_INDICES(i),1,matrix%ROW_INDICES(i+1)-1,8,8,matrix%DATA_INTG,initial_string, &
1319  & '(20X,8(X,I13))',err,error,*999)
1320  CASE(matrix_vector_sp_type)
1321  initial_string='("Matrix('//row_string//',:):",8(X,E13.6))'
1322  CALL write_string_vector(id,matrix%ROW_INDICES(i),1,matrix%ROW_INDICES(i+1)-1,8,8,matrix%DATA_SP,initial_string, &
1323  & '(20X,8(X,E13.6))',err,error,*999)
1324  CASE(matrix_vector_dp_type)
1325  initial_string='("Matrix('//row_string//',:):",8(X,E13.6))'
1326  CALL write_string_vector(id,matrix%ROW_INDICES(i),1,matrix%ROW_INDICES(i+1)-1,8,8,matrix%DATA_DP,initial_string, &
1327  & '(20X,8(X,E13.6))',err,error,*999)
1328  CASE(matrix_vector_l_type)
1329  initial_string='("Matrix('//row_string//',:):",8(X,L13))'
1330  CALL write_string_vector(id,matrix%ROW_INDICES(i),1,matrix%ROW_INDICES(i+1)-1,8,8,matrix%DATA_L,initial_string, &
1331  & '(20X,8(X,L13))',err,error,*999)
1332  CASE DEFAULT
1333  local_error="The matrix data type of "//trim(number_to_vstring(matrix%DATA_TYPE,"*",err,error))//" is invalid."
1334  CALL flagerror(local_error,err,error,*999)
1335  END SELECT
1336  ENDDO !i
1338  DO j=1,matrix%N
1339  col_string=number_to_character(j,"I9",err,error)
1340  SELECT CASE(matrix%DATA_TYPE)
1342  initial_string='("Matrix(:,'//col_string//'):",8(X,I13))'
1343  CALL write_string_vector(id,matrix%COLUMN_INDICES(j),1,matrix%COLUMN_INDICES(j+1)-1,8,8,matrix%DATA_INTG, &
1344  & initial_string,'(20X,8(X,I13))',err,error,*999)
1345  CASE(matrix_vector_sp_type)
1346  initial_string='("Matrix(:,'//col_string//'):",8(X,E13.6))'
1347  CALL write_string_vector(id,matrix%COLUMN_INDICES(j),1,matrix%COLUMN_INDICES(j+1)-1,8,8,matrix%DATA_SP, &
1348  & initial_string,'(20X,8(X,E13.6))',err,error,*999)
1349  CASE(matrix_vector_dp_type)
1350  initial_string='("Matrix(:,'//col_string//'):",8(X,E13.6))'
1351  CALL write_string_vector(id,matrix%COLUMN_INDICES(j),1,matrix%COLUMN_INDICES(j+1)-1,8,8,matrix%DATA_DP, &
1352  & initial_string,'(20X,8(X,E13.6))',err,error,*999)
1353  CASE(matrix_vector_l_type)
1354  initial_string='("Matrix(:,'//col_string//'):",8(X,L13))'
1355  CALL write_string_vector(id,matrix%COLUMN_INDICES(j),1,matrix%COLUMN_INDICES(j+1)-1,8,8,matrix%DATA_L, &
1356  & initial_string,'(20X,8(X,L13))',err,error,*999)
1357  CASE DEFAULT
1358  local_error="The matrix data type of "//trim(number_to_vstring(matrix%DATA_TYPE,"*",err,error))//" is invalid."
1359  CALL flagerror(local_error,err,error,*999)
1360  END SELECT
1361  ENDDO !j
1363  CALL flagerror("Not implemented.",err,error,*999)
1364  CASE DEFAULT
1365  local_error="The matrix storage type of "//trim(number_to_vstring(matrix%STORAGE_TYPE,"*",err,error))//" is invalid."
1366  CALL flagerror(local_error,err,error,*999)
1367  END SELECT
1368  ELSE
1369  CALL flagerror("The matrix has not been finished.",err,error,*999)
1370  ENDIF
1371  ELSE
1372  CALL flagerror("Matrix is not associated.",err,error,*999)
1373  ENDIF
1374 
1375  exits("MATRIX_OUTPUT")
1376  RETURN
1377 999 errorsexits("MATRIX_OUTPUT",err,error)
1378  RETURN 1
1379  END SUBROUTINE matrix_output
1380 
1381  !
1382  !================================================================================================================================
1383  !
1384 
1386  SUBROUTINE matrix_size_set(MATRIX,M,N,ERR,ERROR,*)
1388  !Argument variables
1389  TYPE(matrix_type), POINTER :: MATRIX
1390  INTEGER(INTG), INTENT(IN) :: M
1391  INTEGER(INTG), INTENT(IN) :: N
1392  INTEGER(INTG), INTENT(OUT) :: ERR
1393  TYPE(varying_string), INTENT(OUT) :: ERROR
1394  !Local Variables
1395  TYPE(varying_string) :: LOCAL_ERROR
1396 
1397  enters("MATRIX_SIZE_SET",err,error,*999)
1398 
1399  IF(ASSOCIATED(matrix)) THEN
1400  IF(matrix%MATRIX_FINISHED) THEN
1401  CALL flagerror("The matrix has been finished.",err,error,*999)
1402  ELSE
1403  IF(m>0) THEN
1404  IF(n>0) THEN
1405  matrix%M=m
1406  matrix%N=n
1407  ELSE
1408  local_error="The number of matrix columns of "//trim(number_to_vstring(n,"*",err,error))// &
1409  & " is invalid. The number must be >0."
1410  CALL flagerror(local_error,err,error,*999)
1411  ENDIF
1412  ELSE
1413  local_error="The number of matrix rows of "//trim(number_to_vstring(m,"*",err,error))// &
1414  & " is invalid. The number must be >0."
1415  CALL flagerror(local_error,err,error,*999)
1416  ENDIF
1417  ENDIF
1418  ELSE
1419  CALL flagerror("Matrix is not associated.",err,error,*999)
1420  ENDIF
1421 
1422  exits("MATRIX_SIZE_SET")
1423  RETURN
1424 999 errorsexits("MATRIX_SIZE_SET",err,error)
1425  RETURN 1
1426  END SUBROUTINE matrix_size_set
1427 
1428  !
1429  !================================================================================================================================
1430  !
1431 
1433  SUBROUTINE matrix_storage_location_find(MATRIX,I,J,LOCATION,ERR,ERROR,*)
1435  !Argument variables
1436  TYPE(matrix_type), POINTER :: MATRIX
1437  INTEGER(INTG), INTENT(IN) :: I
1438  INTEGER(INTG), INTENT(IN) :: J
1439  INTEGER(INTG), INTENT(OUT) :: LOCATION
1440  INTEGER(INTG), INTENT(OUT) :: ERR
1441  TYPE(varying_string), INTENT(OUT) :: ERROR
1442  !Local variables
1443  INTEGER(INTG) :: k,LOWLIMIT,MIDPOINT,UPLIMIT
1444  LOGICAL :: FOUNDCOLUMN, FOUNDROW
1445  TYPE(varying_string) :: LOCAL_ERROR
1446 
1447  enters("MATRIX_STORAGE_LOCATION_FIND",err,error,*999)
1448 
1449  location=0
1450  IF(ASSOCIATED(matrix)) THEN
1451  IF(matrix%MATRIX_FINISHED) THEN
1452  IF(i<1.OR.i>matrix%M) THEN
1453  local_error="Row number "//trim(number_to_vstring(i,"*",err,error))//" is outside the matrix range of 1 to "// &
1454  & trim(number_to_vstring(matrix%M,"*",err,error))//"."
1455  CALL flagerror(local_error,err,error,*999)
1456  ENDIF
1457  IF(j<1.OR.j>matrix%N) THEN
1458  local_error="Column number "//trim(number_to_vstring(j,"*",err,error))//" is outside the matrix range of 1 to "// &
1459  & trim(number_to_vstring(matrix%M,"*",err,error))//"."
1460  CALL flagerror(local_error,err,error,*999)
1461  ENDIF
1462 
1463  SELECT CASE(matrix%STORAGE_TYPE)
1465  location=i+(j-1)*matrix%M
1467  IF(i==j) location=i
1469  location=i+(j-1)*matrix%MAX_M
1471  location=(i-1)*matrix%MAX_N+j
1473  !Search for the column number in the sparsity list using the bisection (binary search) algorithm
1474  lowlimit=matrix%ROW_INDICES(i)
1475  IF(j>=matrix%COLUMN_INDICES(lowlimit)) THEN
1476  uplimit=matrix%ROW_INDICES(i+1)
1477  IF(uplimit>lowlimit) THEN
1478  IF(j<=matrix%COLUMN_INDICES(uplimit-1)) THEN
1479  DO WHILE((uplimit-lowlimit)>bisectiontolinearsearchthreshold)
1480  midpoint=(uplimit+lowlimit)/2
1481  IF(matrix%COLUMN_INDICES(midpoint)>j) THEN
1482  uplimit=midpoint
1483  ELSE
1484  lowlimit=midpoint
1485  ENDIF
1486  ENDDO
1487  DO k=lowlimit,uplimit
1488  IF(matrix%COLUMN_INDICES(k)==j) THEN
1489  location=k
1490  EXIT
1491  ENDIF
1492  ENDDO !k
1493  ENDIF
1494  ENDIF
1495  ENDIF
1497  !Search for the row number in the sparsity list using the bisection (binary search) algorithm
1498  lowlimit=matrix%COLUMN_INDICES(j)
1499  IF(i>=matrix%ROW_INDICES(lowlimit)) THEN
1500  uplimit=matrix%COLUMN_INDICES(j+1)
1501  IF(uplimit>lowlimit) THEN
1502  IF(i<=matrix%ROW_INDICES(uplimit-1)) THEN
1503  DO WHILE((uplimit-lowlimit)>1)
1504  midpoint=(uplimit+lowlimit)/2
1505  IF(matrix%ROW_INDICES(midpoint)>i) THEN
1506  uplimit=midpoint
1507  ELSE
1508  lowlimit=midpoint
1509  ENDIF
1510  ENDDO
1511  IF(matrix%ROW_INDICES(lowlimit)==i) location=lowlimit
1512  DO WHILE((uplimit-lowlimit)>bisectiontolinearsearchthreshold)
1513  midpoint=(uplimit+lowlimit)/2
1514  IF(matrix%ROW_INDICES(midpoint)>i) THEN
1515  uplimit=midpoint
1516  ELSE
1517  lowlimit=midpoint
1518  ENDIF
1519  ENDDO
1520  DO k=lowlimit,uplimit
1521  IF(matrix%ROW_INDICES(k)==i) THEN
1522  location=k
1523  EXIT
1524  ENDIF
1525  ENDDO !k
1526  ENDIF
1527  ENDIF
1528  ENDIF
1530  foundrow=.false.
1531  location=1
1532  DO WHILE(.NOT.foundcolumn.AND.location<=matrix%SIZE)
1533  IF(matrix%ROW_INDICES(location)==i) THEN
1534  DO WHILE(.NOT.foundcolumn.AND.location<=matrix%SIZE)
1535  IF(matrix%COLUMN_INDICES(location)==j.AND.matrix%ROW_INDICES(location)==i) THEN
1536  foundcolumn=.true.
1537  ELSE IF(matrix%ROW_INDICES(location)/=i) THEN
1538  location=matrix%SIZE+1
1539  ELSE
1540  location=location+1
1541  ENDIF
1542  ENDDO
1543  ELSE
1544  location=location+1
1545  ENDIF
1546  ENDDO
1547  IF(.NOT.(foundrow.AND.foundcolumn)) location=0
1548  CASE DEFAULT
1549  local_error="The matrix storage type of "//trim(number_to_vstring(matrix%STORAGE_TYPE,"*",err,error))//" is invalid."
1550  CALL flagerror(local_error,err,error,*999)
1551  END SELECT
1552  ELSE
1553  CALL flagerror("The matrix has not been finished.",err,error,*999)
1554  ENDIF
1555  ELSE
1556  CALL flagerror("Matrix is not associated.",err,error,*999)
1557  ENDIF
1558 
1559  exits("MATRIX_STORAGE_LOCATION_FIND")
1560  RETURN
1561 999 errorsexits("MATRIX_STORAGE_LOCATION_FIND",err,error)
1562  RETURN 1
1563  END SUBROUTINE matrix_storage_location_find
1564 
1565  !
1566  !================================================================================================================================
1567  !
1568 
1570  SUBROUTINE matrix_storage_locations_get(MATRIX,ROW_INDICES,COLUMN_INDICES,ERR,ERROR,*)
1572  !Argument variables
1573  TYPE(matrix_type), POINTER :: MATRIX
1574  INTEGER(INTG), POINTER :: ROW_INDICES(:)
1575  INTEGER(INTG), POINTER :: COLUMN_INDICES(:)
1576  INTEGER(INTG), INTENT(OUT) :: ERR
1577  TYPE(varying_string), INTENT(OUT) :: ERROR
1578  !Local variables
1579  TYPE(varying_string) :: LOCAL_ERROR
1580 
1581  enters("MATRIX_STORAGE_LOCATIONS_GET",err,error,*999)
1582 
1583  IF(ASSOCIATED(matrix)) THEN
1584  IF(matrix%MATRIX_FINISHED) THEN
1585  SELECT CASE(matrix%STORAGE_TYPE)
1587  CALL flagerror("Can not get matrix locations for a block storage matrix.",err,error,*999)
1589  CALL flagerror("Can not get matrix locations for a diagonal storage matrix.",err,error,*999)
1591  CALL flagerror("Can not get matrix locations for a column major storage matrix.",err,error,*999)
1593  CALL flagerror("Can not get matrix locations for a row major storage matrix.",err,error,*999)
1595  row_indices=>matrix%ROW_INDICES
1596  column_indices=>matrix%COLUMN_INDICES
1598  row_indices=>matrix%ROW_INDICES
1599  column_indices=>matrix%COLUMN_INDICES
1601  row_indices=>matrix%ROW_INDICES
1602  column_indices=>matrix%COLUMN_INDICES
1603  CASE DEFAULT
1604  local_error="The matrix storage type of "//trim(number_to_vstring(matrix%STORAGE_TYPE,"*",err,error))//" is invalid."
1605  CALL flagerror(local_error,err,error,*999)
1606  END SELECT
1607  ELSE
1608  CALL flagerror("Matrix has not been finished.",err,error,*999)
1609  ENDIF
1610  ELSE
1611  CALL flagerror("Matrix is not associated.",err,error,*999)
1612  ENDIF
1613 
1614  exits("MATRIX_STORAGE_LOCATIONS_GET")
1615  RETURN
1616 999 errorsexits("MATRIX_STORAGE_LOCATIONS_GET",err,error)
1617  RETURN 1
1618  END SUBROUTINE matrix_storage_locations_get
1619 
1620  !
1621  !================================================================================================================================
1622  !
1623 
1625  SUBROUTINE matrix_storage_locations_set(MATRIX,ROW_INDICES,COLUMN_INDICES,ERR,ERROR,*)
1627  !Argument variables
1628  TYPE(matrix_type), POINTER :: MATRIX
1629  INTEGER(INTG), INTENT(IN) :: ROW_INDICES(:)
1630  INTEGER(INTG), INTENT(IN) :: COLUMN_INDICES(:)
1631  INTEGER(INTG), INTENT(OUT) :: ERR
1632  TYPE(varying_string), INTENT(OUT) :: ERROR
1633  !Local variables
1634  INTEGER(INTG) :: i,j,k
1635  TYPE(varying_string) :: LOCAL_ERROR
1636 
1637  enters("MATRIX_STORAGE_LOCATIONS_SET",err,error,*999)
1638 
1639  IF(ASSOCIATED(matrix)) THEN
1640  IF(matrix%MATRIX_FINISHED) THEN
1641  CALL flagerror("Matrix has been finished.",err,error,*999)
1642  ELSE
1643  SELECT CASE(matrix%STORAGE_TYPE)
1645  CALL flagerror("Can not set matrix locations for a block storage matrix.",err,error,*999)
1647  CALL flagerror("Can not set matrix locations for a diagonal storage matrix.",err,error,*999)
1649  CALL flagerror("Can not set matrix locations for a column major storage matrix.",err,error,*999)
1651  CALL flagerror("Can not set matrix locations for a row major storage matrix.",err,error,*999)
1653  IF(SIZE(row_indices,1)==matrix%M+1) THEN
1654  IF(SIZE(column_indices,1)==matrix%NUMBER_NON_ZEROS) THEN
1655  IF(row_indices(1)==1) THEN
1656  IF(row_indices(matrix%M+1)==matrix%NUMBER_NON_ZEROS+1) THEN
1657  DO i=2,matrix%M+1
1658  IF(row_indices(i)<row_indices(i-1)) THEN
1659  local_error="Invalid row indices. Row "//trim(number_to_vstring(i,"*",err,error))//" index number ("// &
1660  & trim(number_to_vstring(row_indices(i),"*",err,error))//") is less than row "// &
1661  & trim(number_to_vstring(i-1,"*",err,error))//" index number ("// &
1662  & trim(number_to_vstring(row_indices(i-1),"*",err,error))//")."
1663  CALL flagerror(local_error,err,error,*999)
1664  ENDIF
1665  ENDDO !i
1666  DO i=1,matrix%M
1667  DO j=row_indices(i),row_indices(i+1)-1
1668  k=column_indices(j)
1669  IF(k>0) THEN
1670  IF(k>matrix%N) THEN
1671  local_error="Invalid column indices. Column index "//trim(number_to_vstring(j,"*",err,error))//" ("// &
1672  & trim(number_to_vstring(k,"*",err,error))//") is greater than the number of columns ("// &
1673  & trim(number_to_vstring(matrix%N,"*",err,error))//")."
1674  CALL flagerror(local_error,err,error,*999)
1675  ENDIF
1676  ELSE
1677  local_error="Invalid column indices. Column index "//trim(number_to_vstring(j,"*",err,error))//" ("// &
1678  & trim(number_to_vstring(k,"*",err,error))//") is less than zero."
1679  CALL flagerror(local_error,err,error,*999)
1680  ENDIF
1681  ENDDO !j
1682  ENDDO !i
1683  IF(ALLOCATED(matrix%ROW_INDICES)) DEALLOCATE(matrix%ROW_INDICES)
1684  IF(ALLOCATED(matrix%COLUMN_INDICES)) DEALLOCATE(matrix%COLUMN_INDICES)
1685  ALLOCATE(matrix%ROW_INDICES(matrix%M+1),stat=err)
1686  IF(err/=0) CALL flagerror("Could not allocate matrix row indices.",err,error,*999)
1687  ALLOCATE(matrix%COLUMN_INDICES(matrix%NUMBER_NON_ZEROS),stat=err)
1688  IF(err/=0) CALL flagerror("Could not allocate matrix column indices.",err,error,*999)
1689  matrix%ROW_INDICES(1:matrix%M+1)=row_indices(1:matrix%M+1)
1690  matrix%COLUMN_INDICES(1:matrix%NUMBER_NON_ZEROS)=column_indices(1:matrix%NUMBER_NON_ZEROS)
1691  !Don't really need this???
1692  !DO i=1,MATRIX%M
1693  ! CALL LIST_SORT(MATRIX%COLUMN_INDICES(MATRIX%ROW_INDICES(i):MATRIX%ROW_INDICES(i+1)-1),ERR,ERROR,*999)
1694  !ENDDO !i
1695  ELSE
1696  local_error="Invalid row indices. The last row index ("// &
1697  & trim(number_to_vstring(row_indices(matrix%M+1),"*",err,error))// &
1698  & ") does not equal the number of non-zeros + 1 ("// &
1699  & trim(number_to_vstring(matrix%NUMBER_NON_ZEROS+1,"*",err,error))//")."
1700  CALL flagerror(local_error,err,error,*999)
1701  ENDIF
1702  ELSE
1703  local_error="Invalid row indices. The first row index ("// &
1704  & trim(number_to_vstring(row_indices(1),"*",err,error))//") does not equal 1."
1705  CALL flagerror(local_error,err,error,*999)
1706  ENDIF
1707  ELSE
1708  local_error="The supplied number of column indices ("// &
1709  & trim(number_to_vstring(SIZE(column_indices,1),"*",err,error))// &
1710  & ") does not match the number of non-zeros in the matrix ("// &
1711  & trim(number_to_vstring(matrix%NUMBER_NON_ZEROS,"*",err,error))//")."
1712  CALL flagerror(local_error,err,error,*999)
1713  ENDIF
1714  ELSE
1715  local_error="The supplied number of row indices ("//trim(number_to_vstring(SIZE(row_indices,1),"*",err,error))// &
1716  & ") does not match the number of rows in the matrix + 1 ("// &
1717  & trim(number_to_vstring(matrix%M+1,"*",err,error))//")."
1718  CALL flagerror(local_error,err,error,*999)
1719  ENDIF
1721  IF(SIZE(column_indices,1)==matrix%N+1) THEN
1722  IF(SIZE(row_indices,1)==matrix%NUMBER_NON_ZEROS) THEN
1723  IF(column_indices(1)==1) THEN
1724  IF(column_indices(matrix%N+1)==matrix%NUMBER_NON_ZEROS+1) THEN
1725  IF(column_indices(1)/=1) THEN
1726  local_error="Invalid column indices. Column index 1 ("// &
1727  & trim(number_to_vstring(column_indices(1),"*",err,error))//") "// &
1728  & " should be equal to one."
1729  CALL flagerror(local_error,err,error,*999)
1730  END IF
1731  DO j=2,matrix%N+1
1732  IF(column_indices(j)<column_indices(j-1)) THEN
1733  local_error="Invalid column indices. Column "//trim(number_to_vstring(j,"*",err,error))// &
1734  & " index number ("//trim(number_to_vstring(column_indices(j),"*",err,error))//") is less than column "// &
1735  & trim(number_to_vstring(j-1,"*",err,error))//" index number ("// &
1736  & trim(number_to_vstring(column_indices(j-1),"*",err,error))//")."
1737  CALL flagerror(local_error,err,error,*999)
1738  END IF
1739  IF(column_indices(j)<0.OR.column_indices(j)>matrix%NUMBER_NON_ZEROS+1) THEN
1740  local_error="Invalid column indices. Column index "//trim(number_to_vstring(j,"*",err,error))//" ("// &
1741  & trim(number_to_vstring(column_indices(j),"*",err,error))//") "// &
1742  & " should be in the range of one to the number of non-zeros + 1 ("// &
1743  & trim(number_to_vstring(matrix%NUMBER_NON_ZEROS+1,"*",err,error))//")."
1744  CALL flagerror(local_error,err,error,*999)
1745  END IF
1746  ENDDO !i
1747  DO j=1,matrix%N
1748  DO i=column_indices(j),column_indices(j+1)-1
1749  k=row_indices(i)
1750  IF(k>0) THEN
1751  IF(k>matrix%M) THEN
1752  local_error="Invalid row indices. Row index "//trim(number_to_vstring(i,"*",err,error))//" ("// &
1753  & trim(number_to_vstring(k,"*",err,error))//") is greater than the number of rows ("// &
1754  & trim(number_to_vstring(matrix%M,"*",err,error))//")."
1755  CALL flagerror(local_error,err,error,*999)
1756  ENDIF
1757  ELSE
1758  local_error="Invalid row indices. Row index "//trim(number_to_vstring(i,"*",err,error))//" ("// &
1759  & trim(number_to_vstring(k,"*",err,error))//") is less than zero."
1760  CALL flagerror(local_error,err,error,*999)
1761  ENDIF
1762  ENDDO !i
1763  ENDDO !j
1764  IF(ALLOCATED(matrix%ROW_INDICES)) DEALLOCATE(matrix%ROW_INDICES)
1765  IF(ALLOCATED(matrix%COLUMN_INDICES)) DEALLOCATE(matrix%COLUMN_INDICES)
1766  ALLOCATE(matrix%ROW_INDICES(matrix%NUMBER_NON_ZEROS),stat=err)
1767  IF(err/=0) CALL flagerror("Could not allocate matrix row indices.",err,error,*999)
1768  ALLOCATE(matrix%COLUMN_INDICES(matrix%N+1),stat=err)
1769  IF(err/=0) CALL flagerror("Could not allocate matrix column indices.",err,error,*999)
1770  matrix%ROW_INDICES(1:matrix%NUMBER_NON_ZEROS)=row_indices(1:matrix%NUMBER_NON_ZEROS)
1771  matrix%COLUMN_INDICES(1:matrix%N+1)=column_indices(1:matrix%N+1)
1772  !Don't really need this???
1773  !DO j=1,MATRIX%N
1774  ! CALL LIST_SORT(MATRIX%ROW_INDICES(MATRIX%COLUMN_INDICES(j):MATRIX%COLUMN_INDICES(j+1)-1),ERR,ERROR,*999)
1775  !ENDDO !j
1776  ELSE
1777  local_error="Invalid column indices. The last column index ("// &
1778  & trim(number_to_vstring(column_indices(matrix%N+1),"*",err,error))// &
1779  & ") does not equal the number of non-zeros + 1 ("// &
1780  & trim(number_to_vstring(matrix%NUMBER_NON_ZEROS+1,"*",err,error))//")."
1781  CALL flagerror(local_error,err,error,*999)
1782  ENDIF
1783  ELSE
1784  local_error="Invalid column indices. The first column index ("// &
1785  & trim(number_to_vstring(column_indices(1),"*",err,error))//") does not equal 1."
1786  CALL flagerror(local_error,err,error,*999)
1787  ENDIF
1788  ELSE
1789  local_error="The supplied number of row indices ("// &
1790  & trim(number_to_vstring(SIZE(row_indices,1),"*",err,error))// &
1791  & ") does not match the number of non-zeros in the matrix ("// &
1792  & trim(number_to_vstring(matrix%NUMBER_NON_ZEROS,"*",err,error))//")."
1793  CALL flagerror(local_error,err,error,*999)
1794  ENDIF
1795  ELSE
1796  local_error="The supplied number of column indices ("// &
1797  & trim(number_to_vstring(SIZE(column_indices,1),"*",err,error))// &
1798  & ") does not match the number of columns in the matrix + 1 ("// &
1799  & trim(number_to_vstring(matrix%N+1,"*",err,error))//")."
1800  CALL flagerror(local_error,err,error,*999)
1801  ENDIF
1803  IF(SIZE(row_indices,1)==matrix%NUMBER_NON_ZEROS) THEN
1804  IF(SIZE(column_indices,1)==matrix%NUMBER_NON_ZEROS) THEN
1805  DO k=1,matrix%NUMBER_NON_ZEROS
1806  IF(row_indices(k)<1.OR.row_indices(k)>matrix%M) THEN
1807  local_error="Invalid row indices. Row index number "//trim(number_to_vstring(k,"*",err,error))//" ("// &
1808  & trim(number_to_vstring(row_indices(k),"*",err,error))// &
1809  & ") is out of range. The row index must be between 1 and "// &
1810  & trim(number_to_vstring(matrix%M,"*",err,error))//"."
1811  CALL flagerror(local_error,err,error,*999)
1812  ELSE IF(column_indices(k)<1.OR.column_indices(k)>matrix%N) THEN
1813  local_error="Invalid column indices. Column index number "//trim(number_to_vstring(k,"*",err,error))//" ("// &
1814  & trim(number_to_vstring(column_indices(k),"*",err,error))// &
1815  & ") is out of range. The column index must be between 1 and "// &
1816  & trim(number_to_vstring(matrix%N,"*",err,error))//"."
1817  CALL flagerror(local_error,err,error,*999)
1818  ENDIF
1819  ENDDO !k
1820  matrix%ROW_INDICES(1:matrix%NUMBER_NON_ZEROS)=row_indices(1:matrix%NUMBER_NON_ZEROS)
1821  matrix%COLUMN_INDICES(1:matrix%NUMBER_NON_ZEROS)=column_indices(1:matrix%NUMBER_NON_ZEROS)
1822  !!TODO: sort the row and colum indices!!!!!
1823  ELSE
1824  local_error="The supplied number of column indices ("// &
1825  & trim(number_to_vstring(SIZE(column_indices,1),"*",err,error))// &
1826  & ") does not match the number of non-zeros in the matrix ("// &
1827  & trim(number_to_vstring(matrix%NUMBER_NON_ZEROS,"*",err,error))//")."
1828  CALL flagerror(local_error,err,error,*999)
1829  ENDIF
1830  ELSE
1831  local_error="The supplied number of row indices ("// &
1832  & trim(number_to_vstring(SIZE(row_indices,1),"*",err,error))// &
1833  & ") does not match the number of non-zeros in the matrix ("// &
1834  & trim(number_to_vstring(matrix%NUMBER_NON_ZEROS,"*",err,error))//")."
1835  CALL flagerror(local_error,err,error,*999)
1836  ENDIF
1837  CASE DEFAULT
1838  local_error="The matrix storage type of "//trim(number_to_vstring(matrix%STORAGE_TYPE,"*",err,error))//" is invalid."
1839  CALL flagerror(local_error,err,error,*999)
1840  END SELECT
1841  ENDIF
1842  ELSE
1843  CALL flagerror("Matrix is not associated.",err,error,*999)
1844  ENDIF
1845 
1846  exits("MATRIX_STORAGE_LOCATIONS_SET")
1847  RETURN
1848 999 errorsexits("MATRIX_STORAGE_LOCATIONS_SET",err,error)
1849  RETURN 1
1850  END SUBROUTINE matrix_storage_locations_set
1851 
1852  !
1853  !================================================================================================================================
1854  !
1855 
1857  SUBROUTINE matrix_storage_type_get(MATRIX,STORAGE_TYPE,ERR,ERROR,*)
1859  !Argument variables
1860  TYPE(matrix_type), POINTER :: MATRIX
1861  INTEGER(INTG), INTENT(OUT) :: STORAGE_TYPE
1862  INTEGER(INTG), INTENT(OUT) :: ERR
1863  TYPE(varying_string), INTENT(OUT) :: ERROR
1864  !Local Variables
1865 
1866  enters("MATRIX_STORAGE_TYPE_GET",err,error,*999)
1867 
1868  IF(ASSOCIATED(matrix)) THEN
1869  IF(matrix%MATRIX_FINISHED) THEN
1870  storage_type=matrix%STORAGE_TYPE
1871  ELSE
1872  CALL flagerror("The matrix has not been finished.",err,error,*999)
1873  ENDIF
1874  ELSE
1875  CALL flagerror("Matrix is not associated.",err,error,*999)
1876  ENDIF
1877 
1878  exits("MATRIX_STORAGE_TYPE_GET")
1879  RETURN
1880 999 errorsexits("MATRIX_STORAGE_TYPE_GET",err,error)
1881  RETURN 1
1882  END SUBROUTINE matrix_storage_type_get
1883 
1884  !
1885  !================================================================================================================================
1886  !
1887 
1889  SUBROUTINE matrix_storage_type_set(MATRIX,STORAGE_TYPE,ERR,ERROR,*)
1891  !Argument variables
1892  TYPE(matrix_type), POINTER :: MATRIX
1893  INTEGER(INTG), INTENT(IN) :: STORAGE_TYPE
1894  INTEGER(INTG), INTENT(OUT) :: ERR
1895  TYPE(varying_string), INTENT(OUT) :: ERROR
1896  !Local Variables
1897  TYPE(varying_string) :: LOCAL_ERROR
1898 
1899  enters("MATRIX_STORAGE_TYPE_SET",err,error,*999)
1900 
1901  IF(ASSOCIATED(matrix)) THEN
1902  IF(matrix%MATRIX_FINISHED) THEN
1903  CALL flagerror("The matrix has been finished.",err,error,*999)
1904  ELSE
1905  SELECT CASE(storage_type)
1907  matrix%STORAGE_TYPE=matrix_block_storage_type
1909  matrix%STORAGE_TYPE=matrix_diagonal_storage_type
1911  matrix%STORAGE_TYPE=matrix_column_major_storage_type
1913  matrix%STORAGE_TYPE=matrix_row_major_storage_type
1915  matrix%STORAGE_TYPE=matrix_compressed_row_storage_type
1917  matrix%STORAGE_TYPE=matrix_compressed_column_storage_type
1919  matrix%STORAGE_TYPE=matrix_row_column_storage_type
1920  CASE DEFAULT
1921  local_error="The matrix storage type of "//trim(number_to_vstring(storage_type,"*",err,error))//" is invalid."
1922  CALL flagerror(local_error,err,error,*999)
1923  END SELECT
1924  ENDIF
1925  ELSE
1926  CALL flagerror("Matrix is not associated.",err,error,*999)
1927  ENDIF
1928 
1929  exits("MATRIX_STORAGE_TYPE_SET")
1930  RETURN
1931 999 errorsexits("MATRIX_STORAGE_TYPE_SET",err,error)
1932  RETURN 1
1933  END SUBROUTINE matrix_storage_type_set
1934 
1935  !
1936  !================================================================================================================================
1937  !
1938 
1940  SUBROUTINE matrix_values_add_intg(MATRIX,ROW_INDICES,COLUMN_INDICES,VALUES,ERR,ERROR,*)
1942  !Argument variables
1943  TYPE(matrix_type), POINTER :: MATRIX
1944  INTEGER(INTG), INTENT(IN) :: ROW_INDICES(:)
1945  INTEGER(INTG), INTENT(IN) :: COLUMN_INDICES(:)
1946  INTEGER(INTG), INTENT(IN) :: VALUES(:)
1947  INTEGER(INTG), INTENT(OUT) :: ERR
1948  TYPE(varying_string), INTENT(OUT) :: ERROR
1949  !Local variables
1950  INTEGER(INTG) :: k,LOCATION
1951  TYPE(varying_string) :: LOCAL_ERROR
1952 
1953  enters("MATRIX_VALUES_ADD_INTG",err,error,*999)
1954 
1955  IF(ASSOCIATED(matrix)) THEN
1956  IF(matrix%MATRIX_FINISHED) THEN
1957  IF(SIZE(row_indices,1)==SIZE(values,1)) THEN
1958  IF(SIZE(column_indices,1)==SIZE(values,1)) THEN
1959  IF(matrix%DATA_TYPE==matrix_vector_intg_type) THEN
1960  DO k=1,SIZE(row_indices,1)
1961  CALL matrix_storage_location_find(matrix,row_indices(k),column_indices(k),location,err,error,*999)
1962  IF(location==0) THEN
1963  local_error="Row "//trim(number_to_vstring(row_indices(k),"*",err,error))//" and column "// &
1964  & trim(number_to_vstring(column_indices(k),"*",err,error))//" does not exist in the matrix."
1965  CALL flagerror(local_error,err,error,*999)
1966  ELSE
1967  matrix%DATA_INTG(location)=matrix%DATA_INTG(location)+values(k)
1968  ENDIF
1969  ENDDO !k
1970  ELSE
1971  local_error="The data type of "//trim(number_to_vstring(matrix%DATA_TYPE,"*",err,error))// &
1972  & " does not correspond to the integer data type of the given values."
1973  CALL flagerror(local_error,err,error,*999)
1974  ENDIF
1975  ELSE
1976  local_error="The size of the column indices array ("// &
1977  & trim(number_to_vstring(SIZE(column_indices,1),"*",err,error))// &
1978  & ") does not conform to the size of the values array ("//trim(number_to_vstring(SIZE(values,1),"*",err,error))//")."
1979  CALL flagerror(local_error,err,error,*999)
1980  ENDIF
1981  ELSE
1982  local_error="The size of the row indices array ("// &
1983  & trim(number_to_vstring(SIZE(row_indices,1),"*",err,error))// &
1984  & ") does not conform to the size of the values array ("//trim(number_to_vstring(SIZE(values,1),"*",err,error))//")."
1985  CALL flagerror(local_error,err,error,*999)
1986  ENDIF
1987  ELSE
1988  CALL flagerror("The matrix has not been finished.",err,error,*999)
1989  ENDIF
1990  ELSE
1991  CALL flagerror("Matrix is not associated.",err,error,*999)
1992  ENDIF
1993 
1994  exits("MATRIX_VALUES_ADD_INTG")
1995  RETURN
1996 999 errorsexits("MATRIX_VALUES_ADD_INTG",err,error)
1997  RETURN 1
1998  END SUBROUTINE matrix_values_add_intg
1999 
2000  !
2001  !================================================================================================================================
2002  !
2003 
2005  SUBROUTINE matrix_values_add_intg1(MATRIX,ROW_INDEX,COLUMN_INDEX,VALUE,ERR,ERROR,*)
2007  !Argument variables
2008  TYPE(matrix_type), POINTER :: MATRIX
2009  INTEGER(INTG), INTENT(IN) :: ROW_INDEX
2010  INTEGER(INTG), INTENT(IN) :: COLUMN_INDEX
2011  INTEGER(INTG), INTENT(IN) :: VALUE
2012  INTEGER(INTG), INTENT(OUT) :: ERR
2013  TYPE(varying_string), INTENT(OUT) :: ERROR
2014  !Local variables
2015  INTEGER(INTG) :: LOCATION
2016  TYPE(varying_string) :: LOCAL_ERROR
2017 
2018  enters("MATRIX_VALUES_ADD_INTG1",err,error,*999)
2019 
2020  IF(ASSOCIATED(matrix)) THEN
2021  IF(matrix%MATRIX_FINISHED) THEN
2022  IF(matrix%DATA_TYPE==matrix_vector_intg_type) THEN
2023  CALL matrix_storage_location_find(matrix,row_index,column_index,location,err,error,*999)
2024  IF(location==0) THEN
2025  local_error="Row "//trim(number_to_vstring(row_index,"*",err,error))//" and column "// &
2026  & trim(number_to_vstring(column_index,"*",err,error))//" does not exist in the matrix."
2027  CALL flagerror(local_error,err,error,*999)
2028  ELSE
2029  matrix%DATA_INTG(location)=matrix%DATA_INTG(location)+VALUE
2030  ENDIF
2031  ELSE
2032  local_error="The data type of "//trim(number_to_vstring(matrix%DATA_TYPE,"*",err,error))// &
2033  & " does not correspond to the integer data type of the given value."
2034  CALL flagerror(local_error,err,error,*999)
2035  ENDIF
2036  ELSE
2037  CALL flagerror("The matrix has not been finished.",err,error,*999)
2038  ENDIF
2039  ELSE
2040  CALL flagerror("Matrix is not associated.",err,error,*999)
2041  ENDIF
2042 
2043  exits("MATRIX_VALUES_ADD_INTG1")
2044  RETURN
2045 999 errorsexits("MATRIX_VALUES_ADD_INTG1",err,error)
2046  RETURN 1
2047  END SUBROUTINE matrix_values_add_intg1
2048 
2049  !
2050  !================================================================================================================================
2051  !
2052 
2054  SUBROUTINE matrix_values_add_intg2(MATRIX,ROW_INDICES,COLUMN_INDICES,VALUES,ERR,ERROR,*)
2056  !Argument variables
2057  TYPE(matrix_type), POINTER :: MATRIX
2058  INTEGER(INTG), INTENT(IN) :: ROW_INDICES(:)
2059  INTEGER(INTG), INTENT(IN) :: COLUMN_INDICES(:)
2060  INTEGER(INTG), INTENT(IN) :: VALUES(:,:)
2061  INTEGER(INTG), INTENT(OUT) :: ERR
2062  TYPE(varying_string), INTENT(OUT) :: ERROR
2063  !Local variables
2064  INTEGER(INTG) :: i,j,k,ROW_INDEX,PREVIOUS_ROW_INDEX,COLUMN_INDEX,PREVIOUS_COLUMN_INDEX,LOCATION,LOWLIMIT,MIDPOINT,UPLIMIT
2065  LOGICAL :: FOUNDCOLUMN, FOUNDROW
2066  TYPE(varying_string) :: LOCAL_ERROR
2067 
2068  enters("MATRIX_VALUES_ADD_INTG2",err,error,*999)
2069 
2070  IF(ASSOCIATED(matrix)) THEN
2071  IF(matrix%MATRIX_FINISHED) THEN
2072  IF(SIZE(row_indices,1)==SIZE(values,1)) THEN
2073  IF(SIZE(column_indices,1)==SIZE(values,2)) THEN
2074  IF(matrix%DATA_TYPE==matrix_vector_dp_type) THEN
2075  SELECT CASE(matrix%STORAGE_TYPE)
2077  DO j=1,SIZE(column_indices,1)
2078  column_index=column_indices(j)
2079  DO i=1,SIZE(row_indices,1)
2080  row_index=row_indices(i)
2081  location=row_index+(column_index-1)*matrix%M
2082  IF(location==0) THEN
2083  local_error="Row "//trim(number_to_vstring(row_indices(i),"*",err,error))//" and column "// &
2084  & trim(number_to_vstring(column_indices(j),"*",err,error))//" does not exist in the matrix."
2085  CALL flagerror(local_error,err,error,*999)
2086  ELSE
2087  matrix%DATA_INTG(location)=matrix%DATA_INTG(location)+values(i,j)
2088  ENDIF
2089  ENDDO !i
2090  ENDDO !j
2092  DO i=1,SIZE(row_indices,1)
2093  row_index=row_indices(i)
2094  DO j=1,SIZE(column_indices,1)
2095  location=0
2096  column_index=column_indices(j)
2097  IF(row_index==column_index) location=row_index
2098  IF(location==0) THEN
2099  local_error="Row "//trim(number_to_vstring(row_indices(i),"*",err,error))//" and column "// &
2100  & trim(number_to_vstring(column_indices(j),"*",err,error))//" does not exist in the matrix."
2101  CALL flagerror(local_error,err,error,*999)
2102  ELSE
2103  matrix%DATA_INTG(location)=matrix%DATA_INTG(location)+values(i,j)
2104  ENDIF
2105  ENDDO !j
2106  ENDDO !i
2108  DO j=1,SIZE(column_indices,1)
2109  column_index=column_indices(j)
2110  DO i=1,SIZE(row_indices,1)
2111  row_index=row_indices(i)
2112  location=row_index+(column_index-1)*matrix%MAX_M
2113  IF(location==0) THEN
2114  local_error="Row "//trim(number_to_vstring(row_indices(i),"*",err,error))//" and column "// &
2115  & trim(number_to_vstring(column_indices(j),"*",err,error))//" does not exist in the matrix."
2116  CALL flagerror(local_error,err,error,*999)
2117  ELSE
2118  matrix%DATA_INTG(location)=matrix%DATA_INTG(location)+values(i,j)
2119  ENDIF
2120  ENDDO !i
2121  ENDDO !j
2123  DO i=1,SIZE(row_indices,1)
2124  row_index=row_indices(i)
2125  DO j=1,SIZE(column_indices,1)
2126  column_index=column_indices(j)
2127  location=(row_index-1)*matrix%MAX_N+column_index
2128  IF(location==0) THEN
2129  local_error="Row "//trim(number_to_vstring(row_indices(i),"*",err,error))//" and column "// &
2130  & trim(number_to_vstring(column_indices(j),"*",err,error))//" does not exist in the matrix."
2131  CALL flagerror(local_error,err,error,*999)
2132  ELSE
2133  matrix%DATA_INTG(location)=matrix%DATA_INTG(location)+values(i,j)
2134  ENDIF
2135  ENDDO !j
2136  ENDDO !i
2138  !Search for the column number in the sparsity list using the bisection (binary search) algorithm
2139  previous_column_index=-1
2140  DO i=1,SIZE(row_indices,1)
2141  row_index=row_indices(i)
2142  lowlimit=matrix%ROW_INDICES(row_index)
2143  uplimit=matrix%ROW_INDICES(row_index+1)
2144  DO j=1,SIZE(column_indices,1)
2145  location=0
2146  column_index=column_indices(j)
2147  IF(column_index<=previous_column_index) THEN
2148  lowlimit=matrix%ROW_INDICES(row_index)
2149  ELSE
2150  uplimit=matrix%ROW_INDICES(row_index+1)
2151  ENDIF
2152  previous_column_index=column_index
2153  DO WHILE((uplimit-lowlimit)>bisectiontolinearsearchthreshold)
2154  midpoint=(uplimit+lowlimit)/2
2155  IF(matrix%COLUMN_INDICES(midpoint)>column_index) THEN
2156  uplimit=midpoint
2157  ELSE
2158  lowlimit=midpoint
2159  ENDIF
2160  ENDDO
2161  DO k=lowlimit,uplimit
2162  IF(matrix%COLUMN_INDICES(k)==column_index) THEN
2163  location=k
2164  lowlimit=k+1
2165  EXIT
2166  ENDIF
2167  ENDDO !k
2168  IF(location==0) THEN
2169  local_error="Row "//trim(number_to_vstring(row_indices(i),"*",err,error))//" and column "// &
2170  & trim(number_to_vstring(column_indices(j),"*",err,error))//" does not exist in the matrix."
2171  CALL flagerror(local_error,err,error,*999)
2172  ELSE
2173  matrix%DATA_INTG(location)=matrix%DATA_INTG(location)+values(i,j)
2174  ENDIF
2175  ENDDO !j
2176  ENDDO !i
2178  !Search for the row number in the sparsity list using the bisection (binary search) algorithm
2179  previous_row_index=-1
2180  DO j=1,SIZE(column_indices,1)
2181  column_index=column_indices(j)
2182  lowlimit=matrix%COLUMN_INDICES(column_index)
2183  uplimit=matrix%COLUMN_INDICES(column_index+1)
2184  DO i=1,SIZE(row_indices,1)
2185  location=0
2186  row_index=row_indices(i)
2187  IF(row_index<=previous_row_index) THEN
2188  lowlimit=matrix%COLUMN_INDICES(column_index)
2189  ELSE
2190  uplimit=matrix%COLUMN_INDICES(column_index+1)
2191  ENDIF
2192  previous_row_index=row_index
2193  DO WHILE((uplimit-lowlimit)>bisectiontolinearsearchthreshold)
2194  midpoint=(uplimit+lowlimit)/2
2195  IF(matrix%ROW_INDICES(midpoint)>row_index) THEN
2196  uplimit=midpoint
2197  ELSE
2198  lowlimit=midpoint
2199  ENDIF
2200  ENDDO
2201  DO k=lowlimit,uplimit
2202  IF(matrix%ROW_INDICES(k)==row_index) THEN
2203  location=k
2204  lowlimit=k+1
2205  EXIT
2206  ENDIF
2207  ENDDO !k
2208  IF(location==0) THEN
2209  local_error="Row "//trim(number_to_vstring(row_indices(i),"*",err,error))//" and column "// &
2210  & trim(number_to_vstring(column_indices(j),"*",err,error))//" does not exist in the matrix."
2211  CALL flagerror(local_error,err,error,*999)
2212  ELSE
2213  matrix%DATA_INTG(location)=matrix%DATA_INTG(location)+values(i,j)
2214  ENDIF
2215  ENDDO !i
2216  ENDDO !j
2218  DO i=1,SIZE(row_indices,1)
2219  row_index=row_indices(i)
2220  DO j=1,SIZE(column_indices,1)
2221  column_index=column_indices(j)
2222  foundrow=.false.
2223  location=1
2224  DO WHILE(.NOT.foundcolumn.AND.location<=matrix%SIZE)
2225  IF(matrix%ROW_INDICES(location)==row_index) THEN
2226  DO WHILE(.NOT.foundcolumn.AND.location<=matrix%SIZE)
2227  IF(matrix%COLUMN_INDICES(location)==column_index.AND.matrix%ROW_INDICES(location)==row_index) THEN
2228  foundcolumn=.true.
2229  ELSE IF(matrix%ROW_INDICES(location)/=row_index) THEN
2230  location=matrix%SIZE+1
2231  ELSE
2232  location=location+1
2233  ENDIF
2234  ENDDO
2235  ELSE
2236  location=location+1
2237  ENDIF
2238  ENDDO
2239  IF(.NOT.(foundrow.AND.foundcolumn)) location=0
2240  IF(location==0) THEN
2241  local_error="Row "//trim(number_to_vstring(row_indices(i),"*",err,error))//" and column "// &
2242  & trim(number_to_vstring(column_indices(j),"*",err,error))//" does not exist in the matrix."
2243  CALL flagerror(local_error,err,error,*999)
2244  ELSE
2245  matrix%DATA_INTG(location)=matrix%DATA_INTG(location)+values(i,j)
2246  ENDIF
2247  ENDDO !j
2248  ENDDO !i
2249  CASE DEFAULT
2250  local_error="The matrix storage type of "//trim(number_to_vstring(matrix%STORAGE_TYPE,"*",err,error))// &
2251  & " is invalid."
2252  CALL flagerror(local_error,err,error,*999)
2253  END SELECT
2254  ELSE
2255  local_error="The data type of "//trim(number_to_vstring(matrix%DATA_TYPE,"*",err,error))// &
2256  & " does not correspond to the integer data type of the given values."
2257  CALL flagerror(local_error,err,error,*999)
2258  ENDIF
2259  ELSE
2260  local_error="The size of the column indices array ("// &
2261  & trim(number_to_vstring(SIZE(column_indices,1),"*",err,error))// &
2262  & ") does not conform to the number of columns in the values array ("// &
2263  & trim(number_to_vstring(SIZE(values,2),"*",err,error))//")."
2264  CALL flagerror(local_error,err,error,*999)
2265  ENDIF
2266  ELSE
2267  local_error="The size of the row indices array ("// &
2268  & trim(number_to_vstring(SIZE(row_indices,1),"*",err,error))// &
2269  & ") does not conform to the number of rows the values array ("// &
2270  & trim(number_to_vstring(SIZE(values,1),"*",err,error))//")."
2271  CALL flagerror(local_error,err,error,*999)
2272  ENDIF
2273  ELSE
2274  CALL flagerror("The matrix has not been finished.",err,error,*999)
2275  ENDIF
2276  ELSE
2277  CALL flagerror("Matrix is not associated.",err,error,*999)
2278  ENDIF
2279 
2280  exits("MATRIX_VALUES_ADD_INTG2")
2281  RETURN
2282 999 errorsexits("MATRIX_VALUES_ADD_INTG2",err,error)
2283  RETURN 1
2284  END SUBROUTINE matrix_values_add_intg2
2285 
2286  !
2287  !================================================================================================================================
2288  !
2289 
2291  SUBROUTINE matrix_values_add_sp(MATRIX,ROW_INDICES,COLUMN_INDICES,VALUES,ERR,ERROR,*)
2293  !Argument variables
2294  TYPE(matrix_type), POINTER :: MATRIX
2295  INTEGER(INTG), INTENT(IN) :: ROW_INDICES(:)
2296  INTEGER(INTG), INTENT(IN) :: COLUMN_INDICES(:)
2297  REAL(SP), INTENT(IN) :: VALUES(:)
2298  INTEGER(INTG), INTENT(OUT) :: ERR
2299  TYPE(varying_string), INTENT(OUT) :: ERROR
2300  !Local variables
2301  INTEGER(INTG) :: k,LOCATION
2302  TYPE(varying_string) :: LOCAL_ERROR
2303 
2304  enters("MATRIX_VALUES_ADD_SP",err,error,*999)
2305 
2306  IF(ASSOCIATED(matrix)) THEN
2307  IF(matrix%MATRIX_FINISHED) THEN
2308  IF(SIZE(row_indices,1)==SIZE(values,1)) THEN
2309  IF(SIZE(column_indices,1)==SIZE(values,1)) THEN
2310  IF(matrix%DATA_TYPE==matrix_vector_sp_type) THEN
2311  DO k=1,SIZE(row_indices,1)
2312  CALL matrix_storage_location_find(matrix,row_indices(k),column_indices(k),location,err,error,*999)
2313  IF(location==0) THEN
2314  local_error="Row "//trim(number_to_vstring(row_indices(k),"*",err,error))//" and column "// &
2315  & trim(number_to_vstring(column_indices(k),"*",err,error))//" does not exist in the matrix."
2316  CALL flagerror(local_error,err,error,*999)
2317  ELSE
2318  matrix%DATA_SP(location)=matrix%DATA_SP(location)+values(k)
2319  ENDIF
2320  ENDDO !k
2321  ELSE
2322  local_error="The data type of "//trim(number_to_vstring(matrix%DATA_TYPE,"*",err,error))// &
2323  & " does not correspond to the single precision data type of the given values."
2324  CALL flagerror(local_error,err,error,*999)
2325  ENDIF
2326  ELSE
2327  local_error="The size of the column indices array ("// &
2328  & trim(number_to_vstring(SIZE(column_indices,1),"*",err,error))// &
2329  & ") does not conform to the size of the values array ("//trim(number_to_vstring(SIZE(values,1),"*",err,error))//")."
2330  CALL flagerror(local_error,err,error,*999)
2331  ENDIF
2332  ELSE
2333  local_error="The size of the row indices array ("// &
2334  & trim(number_to_vstring(SIZE(row_indices,1),"*",err,error))// &
2335  & ") does not conform to the size of the values array ("//trim(number_to_vstring(SIZE(values,1),"*",err,error))//")."
2336  CALL flagerror(local_error,err,error,*999)
2337  ENDIF
2338  ELSE
2339  CALL flagerror("The matrix has not been finished.",err,error,*999)
2340  ENDIF
2341  ELSE
2342  CALL flagerror("Matrix is not associated.",err,error,*999)
2343  ENDIF
2344 
2345  exits("MATRIX_VALUES_ADD_SP")
2346  RETURN
2347 999 errorsexits("MATRIX_VALUES_ADD_SP",err,error)
2348  RETURN 1
2349  END SUBROUTINE matrix_values_add_sp
2350 
2351  !
2352  !================================================================================================================================
2353  !
2354 
2356  SUBROUTINE matrix_values_add_sp1(MATRIX,ROW_INDEX,COLUMN_INDEX,VALUE,ERR,ERROR,*)
2358  !Argument variables
2359  TYPE(matrix_type), POINTER :: MATRIX
2360  INTEGER(INTG), INTENT(IN) :: ROW_INDEX
2361  INTEGER(INTG), INTENT(IN) :: COLUMN_INDEX
2362  REAL(SP), INTENT(IN) :: VALUE
2363  INTEGER(INTG), INTENT(OUT) :: ERR
2364  TYPE(varying_string), INTENT(OUT) :: ERROR
2365  !Local variables
2366  INTEGER(INTG) :: LOCATION
2367  TYPE(varying_string) :: LOCAL_ERROR
2368 
2369  enters("MATRIX_VALUES_ADD_SP1",err,error,*999)
2370 
2371  IF(ASSOCIATED(matrix)) THEN
2372  IF(matrix%MATRIX_FINISHED) THEN
2373  IF(matrix%DATA_TYPE==matrix_vector_sp_type) THEN
2374  CALL matrix_storage_location_find(matrix,row_index,column_index,location,err,error,*999)
2375  IF(location==0) THEN
2376  local_error="Row "//trim(number_to_vstring(row_index,"*",err,error))//" and column "// &
2377  & trim(number_to_vstring(column_index,"*",err,error))//" does not exist in the matrix."
2378  CALL flagerror(local_error,err,error,*999)
2379  ELSE
2380  matrix%DATA_SP(location)=matrix%DATA_SP(location)+VALUE
2381  ENDIF
2382  ELSE
2383  local_error="The data type of "//trim(number_to_vstring(matrix%DATA_TYPE,"*",err,error))// &
2384  & " does not correspond to the single precision data type of the given value."
2385  CALL flagerror(local_error,err,error,*999)
2386  ENDIF
2387  ELSE
2388  CALL flagerror("The matrix has not been finished.",err,error,*999)
2389  ENDIF
2390  ELSE
2391  CALL flagerror("Matrix is not associated.",err,error,*999)
2392  ENDIF
2393 
2394  exits("MATRIX_VALUES_ADD_SP1")
2395  RETURN
2396 999 errorsexits("MATRIX_VALUES_ADD_SP1",err,error)
2397  RETURN 1
2398  END SUBROUTINE matrix_values_add_sp1
2399 
2400  !
2401  !================================================================================================================================
2402  !
2403 
2405  SUBROUTINE matrix_values_add_sp2(MATRIX,ROW_INDICES,COLUMN_INDICES,VALUES,ERR,ERROR,*)
2407  !Argument variables
2408  TYPE(matrix_type), POINTER :: MATRIX
2409  INTEGER(INTG), INTENT(IN) :: ROW_INDICES(:)
2410  INTEGER(INTG), INTENT(IN) :: COLUMN_INDICES(:)
2411  REAL(SP), INTENT(IN) :: VALUES(:,:)
2412  INTEGER(INTG), INTENT(OUT) :: ERR
2413  TYPE(varying_string), INTENT(OUT) :: ERROR
2414  !Local variables
2415  INTEGER(INTG) :: i,j,k,ROW_INDEX,PREVIOUS_ROW_INDEX,COLUMN_INDEX,PREVIOUS_COLUMN_INDEX,LOCATION,LOWLIMIT,MIDPOINT,UPLIMIT
2416  LOGICAL :: FOUNDCOLUMN, FOUNDROW
2417  TYPE(varying_string) :: LOCAL_ERROR
2418 
2419  enters("MATRIX_VALUES_ADD_SP2",err,error,*999)
2420 
2421  IF(ASSOCIATED(matrix)) THEN
2422  IF(matrix%MATRIX_FINISHED) THEN
2423  IF(SIZE(row_indices,1)==SIZE(values,1)) THEN
2424  IF(SIZE(column_indices,1)==SIZE(values,2)) THEN
2425  IF(matrix%DATA_TYPE==matrix_vector_dp_type) THEN
2426  SELECT CASE(matrix%STORAGE_TYPE)
2428  DO j=1,SIZE(column_indices,1)
2429  column_index=column_indices(j)
2430  DO i=1,SIZE(row_indices,1)
2431  row_index=row_indices(i)
2432  location=row_index+(column_index-1)*matrix%M
2433  IF(location==0) THEN
2434  local_error="Row "//trim(number_to_vstring(row_indices(i),"*",err,error))//" and column "// &
2435  & trim(number_to_vstring(column_indices(j),"*",err,error))//" does not exist in the matrix."
2436  CALL flagerror(local_error,err,error,*999)
2437  ELSE
2438  matrix%DATA_SP(location)=matrix%DATA_SP(location)+values(i,j)
2439  ENDIF
2440  ENDDO !i
2441  ENDDO !j
2443  DO i=1,SIZE(row_indices,1)
2444  row_index=row_indices(i)
2445  DO j=1,SIZE(column_indices,1)
2446  location=0
2447  column_index=column_indices(j)
2448  IF(row_index==column_index) location=row_index
2449  IF(location==0) THEN
2450  local_error="Row "//trim(number_to_vstring(row_indices(i),"*",err,error))//" and column "// &
2451  & trim(number_to_vstring(column_indices(j),"*",err,error))//" does not exist in the matrix."
2452  CALL flagerror(local_error,err,error,*999)
2453  ELSE
2454  matrix%DATA_SP(location)=matrix%DATA_SP(location)+values(i,j)
2455  ENDIF
2456  ENDDO !j
2457  ENDDO !i
2459  DO j=1,SIZE(column_indices,1)
2460  column_index=column_indices(j)
2461  DO i=1,SIZE(row_indices,1)
2462  row_index=row_indices(i)
2463  location=row_index+(column_index-1)*matrix%MAX_M
2464  IF(location==0) THEN
2465  local_error="Row "//trim(number_to_vstring(row_indices(i),"*",err,error))//" and column "// &
2466  & trim(number_to_vstring(column_indices(j),"*",err,error))//" does not exist in the matrix."
2467  CALL flagerror(local_error,err,error,*999)
2468  ELSE
2469  matrix%DATA_SP(location)=matrix%DATA_SP(location)+values(i,j)
2470  ENDIF
2471  ENDDO !i
2472  ENDDO !j
2474  DO i=1,SIZE(row_indices,1)
2475  row_index=row_indices(i)
2476  DO j=1,SIZE(column_indices,1)
2477  column_index=column_indices(j)
2478  location=(row_index-1)*matrix%MAX_N+column_index
2479  IF(location==0) THEN
2480  local_error="Row "//trim(number_to_vstring(row_indices(i),"*",err,error))//" and column "// &
2481  & trim(number_to_vstring(column_indices(j),"*",err,error))//" does not exist in the matrix."
2482  CALL flagerror(local_error,err,error,*999)
2483  ELSE
2484  matrix%DATA_SP(location)=matrix%DATA_SP(location)+values(i,j)
2485  ENDIF
2486  ENDDO !j
2487  ENDDO !i
2489  !Search for the column number in the sparsity list using the bisection (binary search) algorithm
2490  previous_column_index=-1
2491  DO i=1,SIZE(row_indices,1)
2492  row_index=row_indices(i)
2493  lowlimit=matrix%ROW_INDICES(row_index)
2494  uplimit=matrix%ROW_INDICES(row_index+1)
2495  DO j=1,SIZE(column_indices,1)
2496  location=0
2497  column_index=column_indices(j)
2498  IF(column_index<=previous_column_index) THEN
2499  lowlimit=matrix%ROW_INDICES(row_index)
2500  ELSE
2501  uplimit=matrix%ROW_INDICES(row_index+1)
2502  ENDIF
2503  previous_column_index=column_index
2504  DO WHILE((uplimit-lowlimit)>bisectiontolinearsearchthreshold)
2505  midpoint=(uplimit+lowlimit)/2
2506  IF(matrix%COLUMN_INDICES(midpoint)>column_index) THEN
2507  uplimit=midpoint
2508  ELSE
2509  lowlimit=midpoint
2510  ENDIF
2511  ENDDO
2512  DO k=lowlimit,uplimit
2513  IF(matrix%COLUMN_INDICES(k)==column_index) THEN
2514  location=k
2515  lowlimit=k+1
2516  EXIT
2517  ENDIF
2518  ENDDO !k
2519  IF(location==0) THEN
2520  local_error="Row "//trim(number_to_vstring(row_indices(i),"*",err,error))//" and column "// &
2521  & trim(number_to_vstring(column_indices(j),"*",err,error))//" does not exist in the matrix."
2522  CALL flagerror(local_error,err,error,*999)
2523  ELSE
2524  matrix%DATA_SP(location)=matrix%DATA_SP(location)+values(i,j)
2525  ENDIF
2526  ENDDO !j
2527  ENDDO !i
2529  !Search for the row number in the sparsity list using the bisection (binary search) algorithm
2530  previous_row_index=-1
2531  DO j=1,SIZE(column_indices,1)
2532  column_index=column_indices(j)
2533  lowlimit=matrix%COLUMN_INDICES(column_index)
2534  uplimit=matrix%COLUMN_INDICES(column_index+1)
2535  DO i=1,SIZE(row_indices,1)
2536  location=0
2537  row_index=row_indices(i)
2538  IF(row_index<=previous_row_index) THEN
2539  lowlimit=matrix%COLUMN_INDICES(column_index)
2540  ELSE
2541  uplimit=matrix%COLUMN_INDICES(column_index+1)
2542  ENDIF
2543  previous_row_index=row_index
2544  DO WHILE((uplimit-lowlimit)>bisectiontolinearsearchthreshold)
2545  midpoint=(uplimit+lowlimit)/2
2546  IF(matrix%ROW_INDICES(midpoint)>row_index) THEN
2547  uplimit=midpoint
2548  ELSE
2549  lowlimit=midpoint
2550  ENDIF
2551  ENDDO
2552  DO k=lowlimit,uplimit
2553  IF(matrix%ROW_INDICES(k)==row_index) THEN
2554  location=k
2555  lowlimit=k+1
2556  EXIT
2557  ENDIF
2558  ENDDO !k
2559  IF(location==0) THEN
2560  local_error="Row "//trim(number_to_vstring(row_indices(i),"*",err,error))//" and column "// &
2561  & trim(number_to_vstring(column_indices(j),"*",err,error))//" does not exist in the matrix."
2562  CALL flagerror(local_error,err,error,*999)
2563  ELSE
2564  matrix%DATA_SP(location)=matrix%DATA_SP(location)+values(i,j)
2565  ENDIF
2566  ENDDO !i
2567  ENDDO !j
2569  DO i=1,SIZE(row_indices,1)
2570  row_index=row_indices(i)
2571  DO j=1,SIZE(column_indices,1)
2572  column_index=column_indices(j)
2573  foundrow=.false.
2574  location=1
2575  DO WHILE(.NOT.foundcolumn.AND.location<=matrix%SIZE)
2576  IF(matrix%ROW_INDICES(location)==row_index) THEN
2577  DO WHILE(.NOT.foundcolumn.AND.location<=matrix%SIZE)
2578  IF(matrix%COLUMN_INDICES(location)==column_index.AND.matrix%ROW_INDICES(location)==row_index) THEN
2579  foundcolumn=.true.
2580  ELSE IF(matrix%ROW_INDICES(location)/=row_index) THEN
2581  location=matrix%SIZE+1
2582  ELSE
2583  location=location+1
2584  ENDIF
2585  ENDDO
2586  ELSE
2587  location=location+1
2588  ENDIF
2589  ENDDO
2590  IF(.NOT.(foundrow.AND.foundcolumn)) location=0
2591  IF(location==0) THEN
2592  local_error="Row "//trim(number_to_vstring(row_indices(i),"*",err,error))//" and column "// &
2593  & trim(number_to_vstring(column_indices(j),"*",err,error))//" does not exist in the matrix."
2594  CALL flagerror(local_error,err,error,*999)
2595  ELSE
2596  matrix%DATA_SP(location)=matrix%DATA_SP(location)+values(i,j)
2597  ENDIF
2598  ENDDO !j
2599  ENDDO !i
2600  CASE DEFAULT
2601  local_error="The matrix storage type of "//trim(number_to_vstring(matrix%STORAGE_TYPE,"*",err,error))// &
2602  & " is invalid."
2603  CALL flagerror(local_error,err,error,*999)
2604  END SELECT
2605  ELSE
2606  local_error="The data type of "//trim(number_to_vstring(matrix%DATA_TYPE,"*",err,error))// &
2607  & " does not correspond to the single precision data type of the given values."
2608  CALL flagerror(local_error,err,error,*999)
2609  ENDIF
2610  ELSE
2611  local_error="The size of the column indices array ("// &
2612  & trim(number_to_vstring(SIZE(column_indices,1),"*",err,error))// &
2613  & ") does not conform to the number of columns in the values array ("// &
2614  & trim(number_to_vstring(SIZE(values,2),"*",err,error))//")."
2615  CALL flagerror(local_error,err,error,*999)
2616  ENDIF
2617  ELSE
2618  local_error="The size of the row indices array ("// &
2619  & trim(number_to_vstring(SIZE(row_indices,1),"*",err,error))// &
2620  & ") does not conform to the number of rows the values array ("// &
2621  & trim(number_to_vstring(SIZE(values,1),"*",err,error))//")."
2622  CALL flagerror(local_error,err,error,*999)
2623  ENDIF
2624  ELSE
2625  CALL flagerror("The matrix has not been finished.",err,error,*999)
2626  ENDIF
2627  ELSE
2628  CALL flagerror("Matrix is not associated.",err,error,*999)
2629  ENDIF
2630 
2631  exits("MATRIX_VALUES_ADD_SP2")
2632  RETURN
2633 999 errorsexits("MATRIX_VALUES_ADD_SP2",err,error)
2634  RETURN 1
2635  END SUBROUTINE matrix_values_add_sp2
2636 
2637  !
2638  !================================================================================================================================
2639  !
2640 
2642  SUBROUTINE matrix_values_add_dp(MATRIX,ROW_INDICES,COLUMN_INDICES,VALUES,ERR,ERROR,*)
2644  !Argument variables
2645  TYPE(matrix_type), POINTER :: MATRIX
2646  INTEGER(INTG), INTENT(IN) :: ROW_INDICES(:)
2647  INTEGER(INTG), INTENT(IN) :: COLUMN_INDICES(:)
2648  REAL(DP), INTENT(IN) :: VALUES(:)
2649  INTEGER(INTG), INTENT(OUT) :: ERR
2650  TYPE(varying_string), INTENT(OUT) :: ERROR
2651  !Local variables
2652  INTEGER(INTG) :: k,LOCATION
2653  TYPE(varying_string) :: LOCAL_ERROR
2654 
2655  enters("MATRIX_VALUES_ADD_DP",err,error,*999)
2656 
2657  IF(ASSOCIATED(matrix)) THEN
2658  IF(matrix%MATRIX_FINISHED) THEN
2659  IF(SIZE(row_indices,1)==SIZE(values,1)) THEN
2660  IF(SIZE(column_indices,1)==SIZE(values,1)) THEN
2661  IF(matrix%DATA_TYPE==matrix_vector_dp_type) THEN
2662  DO k=1,SIZE(row_indices,1)
2663  CALL matrix_storage_location_find(matrix,row_indices(k),column_indices(k),location,err,error,*999)
2664  IF(location==0) THEN
2665  local_error="Row "//trim(number_to_vstring(row_indices(k),"*",err,error))//" and column "// &
2666  & trim(number_to_vstring(column_indices(k),"*",err,error))//" does not exist in the matrix."
2667  CALL flagerror(local_error,err,error,*999)
2668  ELSE
2669  matrix%DATA_DP(location)=matrix%DATA_DP(location)+values(k)
2670  ENDIF
2671  ENDDO !k
2672  ELSE
2673  local_error="The data type of "//trim(number_to_vstring(matrix%DATA_TYPE,"*",err,error))// &
2674  & " does not correspond to the double precision data type of the given values."
2675  CALL flagerror(local_error,err,error,*999)
2676  ENDIF
2677  ELSE
2678  local_error="The size of the column indices array ("// &
2679  & trim(number_to_vstring(SIZE(column_indices,1),"*",err,error))// &
2680  & ") does not conform to the size of the values array ("//trim(number_to_vstring(SIZE(values,1),"*",err,error))//")."
2681  CALL flagerror(local_error,err,error,*999)
2682  ENDIF
2683  ELSE
2684  local_error="The size of the row indices array ("// &
2685  & trim(number_to_vstring(SIZE(row_indices,1),"*",err,error))// &
2686  & ") does not conform to the size of the values array ("//trim(number_to_vstring(SIZE(values,1),"*",err,error))//")."
2687  CALL flagerror(local_error,err,error,*999)
2688  ENDIF
2689  ELSE
2690  CALL flagerror("The matrix has not been finished.",err,error,*999)
2691  ENDIF
2692  ELSE
2693  CALL flagerror("Matrix is not associated.",err,error,*999)
2694  ENDIF
2695 
2696  exits("MATRIX_VALUES_ADD_DP")
2697  RETURN
2698 999 errorsexits("MATRIX_VALUES_ADD_DP",err,error)
2699  RETURN 1
2700  END SUBROUTINE matrix_values_add_dp
2701 
2702  !
2703  !================================================================================================================================
2704  !
2705 
2707  SUBROUTINE matrix_values_add_dp1(MATRIX,ROW_INDEX,COLUMN_INDEX,VALUE,ERR,ERROR,*)
2709  !Argument variables
2710  TYPE(matrix_type), POINTER :: MATRIX
2711  INTEGER(INTG), INTENT(IN) :: ROW_INDEX
2712  INTEGER(INTG), INTENT(IN) :: COLUMN_INDEX
2713  REAL(DP), INTENT(IN) :: VALUE
2714  INTEGER(INTG), INTENT(OUT) :: ERR
2715  TYPE(varying_string), INTENT(OUT) :: ERROR
2716  !Local variables
2717  INTEGER(INTG) :: LOCATION
2718  TYPE(varying_string) :: LOCAL_ERROR
2719 
2720  enters("MATRIX_VALUES_ADD_DP1",err,error,*999)
2721 
2722  IF(ASSOCIATED(matrix)) THEN
2723  IF(matrix%MATRIX_FINISHED) THEN
2724  IF(matrix%DATA_TYPE==matrix_vector_dp_type) THEN
2725  CALL matrix_storage_location_find(matrix,row_index,column_index,location,err,error,*999)
2726  IF(location==0) THEN
2727  local_error="Row "//trim(number_to_vstring(row_index,"*",err,error))//" and column "// &
2728  & trim(number_to_vstring(column_index,"*",err,error))//" does not exist in the matrix."
2729  CALL flagerror(local_error,err,error,*999)
2730  ELSE
2731  matrix%DATA_DP(location)=matrix%DATA_DP(location)+VALUE
2732  ENDIF
2733  ELSE
2734  local_error="The data type of "//trim(number_to_vstring(matrix%DATA_TYPE,"*",err,error))// &
2735  & " does not correspond to the double precision data type of the given value."
2736  CALL flagerror(local_error,err,error,*999)
2737  ENDIF
2738  ELSE
2739  CALL flagerror("The matrix has not been finished.",err,error,*999)
2740  ENDIF
2741  ELSE
2742  CALL flagerror("Matrix is not associated.",err,error,*999)
2743  ENDIF
2744 
2745  exits("MATRIX_VALUES_ADD_DP1")
2746  RETURN
2747 999 errorsexits("MATRIX_VALUES_ADD_DP1",err,error)
2748  RETURN 1
2749  END SUBROUTINE matrix_values_add_dp1
2750 
2751  !
2752  !================================================================================================================================
2753  !
2754 
2756  SUBROUTINE matrix_values_add_dp2(MATRIX,ROW_INDICES,COLUMN_INDICES,VALUES,ERR,ERROR,*)
2758  !Argument variables
2759  TYPE(matrix_type), POINTER :: MATRIX
2760  INTEGER(INTG), INTENT(IN) :: ROW_INDICES(:)
2761  INTEGER(INTG), INTENT(IN) :: COLUMN_INDICES(:)
2762  REAL(DP), INTENT(IN) :: VALUES(:,:)
2763  INTEGER(INTG), INTENT(OUT) :: ERR
2764  TYPE(varying_string), INTENT(OUT) :: ERROR
2765  !Local variables
2766  INTEGER(INTG) :: i,j,k,ROW_INDEX,PREVIOUS_ROW_INDEX,COLUMN_INDEX,PREVIOUS_COLUMN_INDEX,LOCATION,LOWLIMIT,MIDPOINT,UPLIMIT
2767  LOGICAL :: FOUNDCOLUMN, FOUNDROW
2768  TYPE(varying_string) :: LOCAL_ERROR
2769 
2770  enters("MATRIX_VALUES_ADD_DP2",err,error,*999)
2771 
2772  IF(ASSOCIATED(matrix)) THEN
2773  IF(matrix%MATRIX_FINISHED) THEN
2774  IF(SIZE(row_indices,1)==SIZE(values,1)) THEN
2775  IF(SIZE(column_indices,1)==SIZE(values,2)) THEN
2776  IF(matrix%DATA_TYPE==matrix_vector_dp_type) THEN
2777  SELECT CASE(matrix%STORAGE_TYPE)
2779  DO j=1,SIZE(column_indices,1)
2780  column_index=column_indices(j)
2781  DO i=1,SIZE(row_indices,1)
2782  row_index=row_indices(i)
2783  location=row_index+(column_index-1)*matrix%M
2784  IF(location==0) THEN
2785  local_error="Row "//trim(number_to_vstring(row_indices(i),"*",err,error))//" and column "// &
2786  & trim(number_to_vstring(column_indices(j),"*",err,error))//" does not exist in the matrix."
2787  CALL flagerror(local_error,err,error,*999)
2788  ELSE
2789  matrix%DATA_DP(location)=matrix%DATA_DP(location)+values(i,j)
2790  ENDIF
2791  ENDDO !i
2792  ENDDO !j
2794  DO i=1,SIZE(row_indices,1)
2795  row_index=row_indices(i)
2796  DO j=1,SIZE(column_indices,1)
2797  location=0
2798  column_index=column_indices(j)
2799  IF(row_index==column_index) location=row_index
2800  IF(location==0) THEN
2801  local_error="Row "//trim(number_to_vstring(row_indices(i),"*",err,error))//" and column "// &
2802  & trim(number_to_vstring(column_indices(j),"*",err,error))//" does not exist in the matrix."
2803  CALL flagerror(local_error,err,error,*999)
2804  ELSE
2805  matrix%DATA_DP(location)=matrix%DATA_DP(location)+values(i,j)
2806  ENDIF
2807  ENDDO !j
2808  ENDDO !i
2810  DO j=1,SIZE(column_indices,1)
2811  column_index=column_indices(j)
2812  DO i=1,SIZE(row_indices,1)
2813  row_index=row_indices(i)
2814  location=row_index+(column_index-1)*matrix%MAX_M
2815  IF(location==0) THEN
2816  local_error="Row "//trim(number_to_vstring(row_indices(i),"*",err,error))//" and column "// &
2817  & trim(number_to_vstring(column_indices(j),"*",err,error))//" does not exist in the matrix."
2818  CALL flagerror(local_error,err,error,*999)
2819  ELSE
2820  matrix%DATA_DP(location)=matrix%DATA_DP(location)+values(i,j)
2821  ENDIF
2822  ENDDO !i
2823  ENDDO !j
2825  DO i=1,SIZE(row_indices,1)
2826  row_index=row_indices(i)
2827  DO j=1,SIZE(column_indices,1)
2828  column_index=column_indices(j)
2829  location=(row_index-1)*matrix%MAX_N+column_index
2830  IF(location==0) THEN
2831  local_error="Row "//trim(number_to_vstring(row_indices(i),"*",err,error))//" and column "// &
2832  & trim(number_to_vstring(column_indices(j),"*",err,error))//" does not exist in the matrix."
2833  CALL flagerror(local_error,err,error,*999)
2834  ELSE
2835  matrix%DATA_DP(location)=matrix%DATA_DP(location)+values(i,j)
2836  ENDIF
2837  ENDDO !j
2838  ENDDO !i
2840  !Search for the column number in the sparsity list using the bisection (binary search) algorithm
2841  previous_column_index=-1
2842  DO i=1,SIZE(row_indices,1)
2843  row_index=row_indices(i)
2844  lowlimit=matrix%ROW_INDICES(row_index)
2845  uplimit=matrix%ROW_INDICES(row_index+1)
2846  DO j=1,SIZE(column_indices,1)
2847  location=0
2848  column_index=column_indices(j)
2849  IF(column_index<=previous_column_index) THEN
2850  lowlimit=matrix%ROW_INDICES(row_index)
2851  ELSE
2852  uplimit=matrix%ROW_INDICES(row_index+1)
2853  ENDIF
2854  previous_column_index=column_index
2855  DO WHILE((uplimit-lowlimit)>bisectiontolinearsearchthreshold)
2856  midpoint=(uplimit+lowlimit)/2
2857  IF(matrix%COLUMN_INDICES(midpoint)>column_index) THEN
2858  uplimit=midpoint
2859  ELSE
2860  lowlimit=midpoint
2861  ENDIF
2862  ENDDO
2863  DO k=lowlimit,uplimit
2864  IF(matrix%COLUMN_INDICES(k)==column_index) THEN
2865  location=k
2866  lowlimit=k+1
2867  EXIT
2868  ENDIF
2869  ENDDO !k
2870  IF(location==0) THEN
2871  local_error="Row "//trim(number_to_vstring(row_indices(i),"*",err,error))//" and column "// &
2872  & trim(number_to_vstring(column_indices(j),"*",err,error))//" does not exist in the matrix."
2873  CALL flagerror(local_error,err,error,*999)
2874  ELSE
2875  matrix%DATA_DP(location)=matrix%DATA_DP(location)+values(i,j)
2876  ENDIF
2877  ENDDO !j
2878  ENDDO !i
2880  !Search for the row number in the sparsity list using the bisection (binary search) algorithm
2881  previous_row_index=-1
2882  DO j=1,SIZE(column_indices,1)
2883  column_index=column_indices(j)
2884  lowlimit=matrix%COLUMN_INDICES(column_index)
2885  uplimit=matrix%COLUMN_INDICES(column_index+1)
2886  DO i=1,SIZE(row_indices,1)
2887  location=0
2888  row_index=row_indices(i)
2889  IF(row_index<=previous_row_index) THEN
2890  lowlimit=matrix%COLUMN_INDICES(column_index)
2891  ELSE
2892  uplimit=matrix%COLUMN_INDICES(column_index+1)
2893  ENDIF
2894  previous_row_index=row_index
2895  DO WHILE((uplimit-lowlimit)>bisectiontolinearsearchthreshold)
2896  midpoint=(uplimit+lowlimit)/2
2897  IF(matrix%ROW_INDICES(midpoint)>row_index) THEN
2898  uplimit=midpoint
2899  ELSE
2900  lowlimit=midpoint
2901  ENDIF
2902  ENDDO
2903  DO k=lowlimit,uplimit
2904  IF(matrix%ROW_INDICES(k)==row_index) THEN
2905  location=k
2906  lowlimit=k+1
2907  EXIT
2908  ENDIF
2909  ENDDO !k
2910  IF(location==0) THEN
2911  local_error="Row "//trim(number_to_vstring(row_indices(i),"*",err,error))//" and column "// &
2912  & trim(number_to_vstring(column_indices(j),"*",err,error))//" does not exist in the matrix."
2913  CALL flagerror(local_error,err,error,*999)
2914  ELSE
2915  matrix%DATA_DP(location)=matrix%DATA_DP(location)+values(i,j)
2916  ENDIF
2917  ENDDO !i
2918  ENDDO !j
2920  DO i=1,SIZE(row_indices,1)
2921  row_index=row_indices(i)
2922  DO j=1,SIZE(column_indices,1)
2923  column_index=column_indices(j)
2924  foundrow=.false.
2925  location=1
2926  DO WHILE(.NOT.foundcolumn.AND.location<=matrix%SIZE)
2927  IF(matrix%ROW_INDICES(location)==row_index) THEN
2928  DO WHILE(.NOT.foundcolumn.AND.location<=matrix%SIZE)
2929  IF(matrix%COLUMN_INDICES(location)==column_index.AND.matrix%ROW_INDICES(location)==row_index) THEN
2930  foundcolumn=.true.
2931  ELSE IF(matrix%ROW_INDICES(location)/=row_index) THEN
2932  location=matrix%SIZE+1
2933  ELSE
2934  location=location+1
2935  ENDIF
2936  ENDDO
2937  ELSE
2938  location=location+1
2939  ENDIF
2940  ENDDO
2941  IF(.NOT.(foundrow.AND.foundcolumn)) location=0
2942  IF(location==0) THEN
2943  local_error="Row "//trim(number_to_vstring(row_indices(i),"*",err,error))//" and column "// &
2944  & trim(number_to_vstring(column_indices(j),"*",err,error))//" does not exist in the matrix."
2945  CALL flagerror(local_error,err,error,*999)
2946  ELSE
2947  matrix%DATA_DP(location)=matrix%DATA_DP(location)+values(i,j)
2948  ENDIF
2949  ENDDO !j
2950  ENDDO !i
2951  CASE DEFAULT
2952  local_error="The matrix storage type of "//trim(number_to_vstring(matrix%STORAGE_TYPE,"*",err,error))// &
2953  & " is invalid."
2954  CALL flagerror(local_error,err,error,*999)
2955  END SELECT
2956  ELSE
2957  local_error="The data type of "//trim(number_to_vstring(matrix%DATA_TYPE,"*",err,error))// &
2958  & " does not correspond to the double precision data type of the given values."
2959  CALL flagerror(local_error,err,error,*999)
2960  ENDIF
2961  ELSE
2962  local_error="The size of the column indices array ("// &
2963  & trim(number_to_vstring(SIZE(column_indices,1),"*",err,error))// &
2964  & ") does not conform to the number of columns in the values array ("// &
2965  & trim(number_to_vstring(SIZE(values,2),"*",err,error))//")."
2966  CALL flagerror(local_error,err,error,*999)
2967  ENDIF
2968  ELSE
2969  local_error="The size of the row indices array ("// &
2970  & trim(number_to_vstring(SIZE(row_indices,1),"*",err,error))// &
2971  & ") does not conform to the number of rows the values array ("// &
2972  & trim(number_to_vstring(SIZE(values,1),"*",err,error))//")."
2973  CALL flagerror(local_error,err,error,*999)
2974  ENDIF
2975  ELSE
2976  CALL flagerror("The matrix has not been finished.",err,error,*999)
2977  ENDIF
2978  ELSE
2979  CALL flagerror("Matrix is not associated.",err,error,*999)
2980  ENDIF
2981 
2982  exits("MATRIX_VALUES_ADD_DP2")
2983  RETURN
2984 999 errorsexits("MATRIX_VALUES_ADD_DP2",err,error)
2985  RETURN 1
2986  END SUBROUTINE matrix_values_add_dp2
2987 
2988  !
2989  !================================================================================================================================
2990  !
2991 
2993  SUBROUTINE matrix_values_add_l(MATRIX,ROW_INDICES,COLUMN_INDICES,VALUES,ERR,ERROR,*)
2995  !Argument variables
2996  TYPE(matrix_type), POINTER :: MATRIX
2997  INTEGER(INTG), INTENT(IN) :: ROW_INDICES(:)
2998  INTEGER(INTG), INTENT(IN) :: COLUMN_INDICES(:)
2999  LOGICAL, INTENT(IN) :: VALUES(:)
3000  INTEGER(INTG), INTENT(OUT) :: ERR
3001  TYPE(varying_string), INTENT(OUT) :: ERROR
3002  !Local variables
3003  INTEGER(INTG) :: k,LOCATION
3004  TYPE(varying_string) :: LOCAL_ERROR
3005 
3006  enters("MATRIX_VALUES_ADD_L",err,error,*999)
3007 
3008  IF(ASSOCIATED(matrix)) THEN
3009  IF(matrix%MATRIX_FINISHED) THEN
3010  IF(SIZE(row_indices,1)==SIZE(values,1)) THEN
3011  IF(SIZE(column_indices,1)==SIZE(values,1)) THEN
3012  IF(matrix%DATA_TYPE==matrix_vector_l_type) THEN
3013  DO k=1,SIZE(row_indices,1)
3014  CALL matrix_storage_location_find(matrix,row_indices(k),column_indices(k),location,err,error,*999)
3015  IF(location==0) THEN
3016  local_error="Row "//trim(number_to_vstring(row_indices(k),"*",err,error))//" and column "// &
3017  & trim(number_to_vstring(column_indices(k),"*",err,error))//" does not exist in the matrix."
3018  CALL flagerror(local_error,err,error,*999)
3019  ELSE
3020  matrix%DATA_L(location)=matrix%DATA_L(location).OR.values(k)
3021  ENDIF
3022  ENDDO !k
3023  ELSE
3024  local_error="The data type of "//trim(number_to_vstring(matrix%DATA_TYPE,"*",err,error))// &
3025  & " does not correspond to the logical data type of the given values."
3026  CALL flagerror(local_error,err,error,*999)
3027  ENDIF
3028  ELSE
3029  local_error="The size of the column indices array ("// &
3030  & trim(number_to_vstring(SIZE(column_indices,1),"*",err,error))// &
3031  & ") does not conform to the size of the values array ("//trim(number_to_vstring(SIZE(values,1),"*",err,error))//")."
3032  CALL flagerror(local_error,err,error,*999)
3033  ENDIF
3034  ELSE
3035  local_error="The size of the row indices array ("// &
3036  & trim(number_to_vstring(SIZE(row_indices,1),"*",err,error))// &
3037  & ") does not conform to the size of the values array ("//trim(number_to_vstring(SIZE(values,1),"*",err,error))//")."
3038  CALL flagerror(local_error,err,error,*999)
3039  ENDIF
3040  ELSE
3041  CALL flagerror("The matrix has not been finished.",err,error,*999)
3042  ENDIF
3043  ELSE
3044  CALL flagerror("Matrix is not associated.",err,error,*999)
3045  ENDIF
3046 
3047  exits("MATRIX_VALUES_ADD_L")
3048  RETURN
3049 999 errorsexits("MATRIX_VALUES_ADD_L",err,error)
3050  RETURN 1
3051  END SUBROUTINE matrix_values_add_l
3052 
3053  !
3054  !================================================================================================================================
3055  !
3056 
3058  SUBROUTINE matrix_values_add_l1(MATRIX,ROW_INDEX,COLUMN_INDEX,VALUE,ERR,ERROR,*)
3060  !Argument variables
3061  TYPE(matrix_type), POINTER :: MATRIX
3062  INTEGER(INTG), INTENT(IN) :: ROW_INDEX
3063  INTEGER(INTG), INTENT(IN) :: COLUMN_INDEX
3064  LOGICAL, INTENT(IN) :: VALUE
3065  INTEGER(INTG), INTENT(OUT) :: ERR
3066  TYPE(varying_string), INTENT(OUT) :: ERROR
3067  !Local variables
3068  INTEGER(INTG) :: LOCATION
3069  TYPE(varying_string) :: LOCAL_ERROR
3070 
3071  enters("MATRIX_VALUES_ADD_L1",err,error,*999)
3072 
3073  IF(ASSOCIATED(matrix)) THEN
3074  IF(matrix%MATRIX_FINISHED) THEN
3075  IF(matrix%DATA_TYPE==matrix_vector_l_type) THEN
3076  CALL matrix_storage_location_find(matrix,row_index,column_index,location,err,error,*999)
3077  IF(location==0) THEN
3078  local_error="Row "//trim(number_to_vstring(row_index,"*",err,error))//" and column "// &
3079  & trim(number_to_vstring(column_index,"*",err,error))//" does not exist in the matrix."
3080  CALL flagerror(local_error,err,error,*999)
3081  ELSE
3082  matrix%DATA_L(location)=matrix%DATA_L(location).OR.VALUE
3083  ENDIF
3084  ELSE
3085  local_error="The data type of "//trim(number_to_vstring(matrix%DATA_TYPE,"*",err,error))// &
3086  & " does not correspond to the logical data type of the given value."
3087  CALL flagerror(local_error,err,error,*999)
3088  ENDIF
3089  ELSE
3090  CALL flagerror("The matrix has not been finished.",err,error,*999)
3091  ENDIF
3092  ELSE
3093  CALL flagerror("Matrix is not associated.",err,error,*999)
3094  ENDIF
3095 
3096  exits("MATRIX_VALUES_ADD_L1")
3097  RETURN
3098 999 errorsexits("MATRIX_VALUES_ADD_L1",err,error)
3099  RETURN 1
3100  END SUBROUTINE matrix_values_add_l1
3101 
3102  !
3103  !================================================================================================================================
3104  !
3105 
3107  SUBROUTINE matrix_values_add_l2(MATRIX,ROW_INDICES,COLUMN_INDICES,VALUES,ERR,ERROR,*)
3109  !Argument variables
3110  TYPE(matrix_type), POINTER :: MATRIX
3111  INTEGER(INTG), INTENT(IN) :: ROW_INDICES(:)
3112  INTEGER(INTG), INTENT(IN) :: COLUMN_INDICES(:)
3113  LOGICAL, INTENT(IN) :: VALUES(:,:)
3114  INTEGER(INTG), INTENT(OUT) :: ERR
3115  TYPE(varying_string), INTENT(OUT) :: ERROR
3116  !Local variables
3117  INTEGER(INTG) :: i,j,k,ROW_INDEX,PREVIOUS_ROW_INDEX,COLUMN_INDEX,PREVIOUS_COLUMN_INDEX,LOCATION,LOWLIMIT,MIDPOINT,UPLIMIT
3118  LOGICAL :: FOUNDCOLUMN, FOUNDROW
3119  TYPE(varying_string) :: LOCAL_ERROR
3120 
3121  enters("MATRIX_VALUES_ADD_L2",err,error,*999)
3122 
3123  IF(ASSOCIATED(matrix)) THEN
3124  IF(matrix%MATRIX_FINISHED) THEN
3125  IF(SIZE(row_indices,1)==SIZE(values,1)) THEN
3126  IF(SIZE(column_indices,1)==SIZE(values,2)) THEN
3127  IF(matrix%DATA_TYPE==matrix_vector_dp_type) THEN
3128  SELECT CASE(matrix%STORAGE_TYPE)
3130  DO j=1,SIZE(column_indices,1)
3131  column_index=column_indices(j)
3132  DO i=1,SIZE(row_indices,1)
3133  row_index=row_indices(i)
3134  location=row_index+(column_index-1)*matrix%M
3135  IF(location==0) THEN
3136  local_error="Row "//trim(number_to_vstring(row_indices(i),"*",err,error))//" and column "// &
3137  & trim(number_to_vstring(column_indices(j),"*",err,error))//" does not exist in the matrix."
3138  CALL flagerror(local_error,err,error,*999)
3139  ELSE
3140  matrix%DATA_L(location)=matrix%DATA_L(location).OR.values(i,j)
3141  ENDIF
3142  ENDDO !i
3143  ENDDO !j
3145  DO i=1,SIZE(row_indices,1)
3146  row_index=row_indices(i)
3147  DO j=1,SIZE(column_indices,1)
3148  location=0
3149  column_index=column_indices(j)
3150  IF(row_index==column_index) location=row_index
3151  IF(location==0) THEN
3152  local_error="Row "//trim(number_to_vstring(row_indices(i),"*",err,error))//" and column "// &
3153  & trim(number_to_vstring(column_indices(j),"*",err,error))//" does not exist in the matrix."
3154  CALL flagerror(local_error,err,error,*999)
3155  ELSE
3156  matrix%DATA_L(location)=matrix%DATA_L(location).OR.values(i,j)
3157  ENDIF
3158  ENDDO !j
3159  ENDDO !i
3161  DO j=1,SIZE(column_indices,1)
3162  column_index=column_indices(j)
3163  DO i=1,SIZE(row_indices,1)
3164  row_index=row_indices(i)
3165  location=row_index+(column_index-1)*matrix%MAX_M
3166  IF(location==0) THEN
3167  local_error="Row "//trim(number_to_vstring(row_indices(i),"*",err,error))//" and column "// &
3168  & trim(number_to_vstring(column_indices(j),"*",err,error))//" does not exist in the matrix."
3169  CALL flagerror(local_error,err,error,*999)
3170  ELSE
3171  matrix%DATA_L(location)=matrix%DATA_L(location).OR.values(i,j)
3172  ENDIF
3173  ENDDO !i
3174  ENDDO !j
3176  DO i=1,SIZE(row_indices,1)
3177  row_index=row_indices(i)
3178  DO j=1,SIZE(column_indices,1)
3179  column_index=column_indices(j)
3180  location=(row_index-1)*matrix%MAX_N+column_index
3181  IF(location==0) THEN
3182  local_error="Row "//trim(number_to_vstring(row_indices(i),"*",err,error))//" and column "// &
3183  & trim(number_to_vstring(column_indices(j),"*",err,error))//" does not exist in the matrix."
3184  CALL flagerror(local_error,err,error,*999)
3185  ELSE
3186  matrix%DATA_L(location)=matrix%DATA_L(location).OR.values(i,j)
3187  ENDIF
3188  ENDDO !j
3189  ENDDO !i
3191  !Search for the column number in the sparsity list using the bisection (binary search) algorithm
3192  previous_column_index=-1
3193  DO i=1,SIZE(row_indices,1)
3194  row_index=row_indices(i)
3195  lowlimit=matrix%ROW_INDICES(row_index)
3196  uplimit=matrix%ROW_INDICES(row_index+1)
3197  DO j=1,SIZE(column_indices,1)
3198  location=0
3199  column_index=column_indices(j)
3200  IF(column_index<=previous_column_index) THEN
3201  lowlimit=matrix%ROW_INDICES(row_index)
3202  ELSE
3203  uplimit=matrix%ROW_INDICES(row_index+1)
3204  ENDIF
3205  previous_column_index=column_index
3206  DO WHILE((uplimit-lowlimit)>bisectiontolinearsearchthreshold)
3207  midpoint=(uplimit+lowlimit)/2
3208  IF(matrix%COLUMN_INDICES(midpoint)>column_index) THEN
3209  uplimit=midpoint
3210  ELSE
3211  lowlimit=midpoint
3212  ENDIF
3213  ENDDO
3214  DO k=lowlimit,uplimit
3215  IF(matrix%COLUMN_INDICES(k)==column_index) THEN
3216  location=k
3217  lowlimit=k+1
3218  EXIT
3219  ENDIF
3220  ENDDO !k
3221  IF(location==0) THEN
3222  local_error="Row "//trim(number_to_vstring(row_indices(i),"*",err,error))//" and column "// &
3223  & trim(number_to_vstring(column_indices(j),"*",err,error))//" does not exist in the matrix."
3224  CALL flagerror(local_error,err,error,*999)
3225  ELSE
3226  matrix%DATA_L(location)=matrix%DATA_L(location).OR.values(i,j)
3227  ENDIF
3228  ENDDO !j
3229  ENDDO !i
3231  !Search for the row number in the sparsity list using the bisection (binary search) algorithm
3232  previous_row_index=-1
3233  DO j=1,SIZE(column_indices,1)
3234  column_index=column_indices(j)
3235  lowlimit=matrix%COLUMN_INDICES(column_index)
3236  uplimit=matrix%COLUMN_INDICES(column_index+1)
3237  DO i=1,SIZE(row_indices,1)
3238  location=0
3239  row_index=row_indices(i)
3240  IF(row_index<=previous_row_index) THEN
3241  lowlimit=matrix%COLUMN_INDICES(column_index)
3242  ELSE
3243  uplimit=matrix%COLUMN_INDICES(column_index+1)
3244  ENDIF
3245  previous_row_index=row_index
3246  DO WHILE((uplimit-lowlimit)>bisectiontolinearsearchthreshold)
3247  midpoint=(uplimit+lowlimit)/2
3248  IF(matrix%ROW_INDICES(midpoint)>row_index) THEN
3249  uplimit=midpoint
3250  ELSE
3251  lowlimit=midpoint
3252  ENDIF
3253  ENDDO
3254  DO k=lowlimit,uplimit
3255  IF(matrix%ROW_INDICES(k)==row_index) THEN
3256  location=k
3257  lowlimit=k+1
3258  EXIT
3259  ENDIF
3260  ENDDO !k
3261  IF(location==0) THEN
3262  local_error="Row "//trim(number_to_vstring(row_indices(i),"*",err,error))//" and column "// &
3263  & trim(number_to_vstring(column_indices(j),"*",err,error))//" does not exist in the matrix."
3264  CALL flagerror(local_error,err,error,*999)
3265  ELSE
3266  matrix%DATA_L(location)=matrix%DATA_L(location).OR.values(i,j)
3267  ENDIF
3268  ENDDO !i
3269  ENDDO !j
3271  DO i=1,SIZE(row_indices,1)
3272  row_index=row_indices(i)
3273  DO j=1,SIZE(column_indices,1)
3274  column_index=column_indices(j)
3275  foundrow=.false.
3276  location=1
3277  DO WHILE(.NOT.foundcolumn.AND.location<=matrix%SIZE)
3278  IF(matrix%ROW_INDICES(location)==row_index) THEN
3279  DO WHILE(.NOT.foundcolumn.AND.location<=matrix%SIZE)
3280  IF(matrix%COLUMN_INDICES(location)==column_index.AND.matrix%ROW_INDICES(location)==row_index) THEN
3281  foundcolumn=.true.
3282  ELSE IF(matrix%ROW_INDICES(location)/=row_index) THEN
3283  location=matrix%SIZE+1
3284  ELSE
3285  location=location+1
3286  ENDIF
3287  ENDDO
3288  ELSE
3289  location=location+1
3290  ENDIF
3291  ENDDO
3292  IF(.NOT.(foundrow.AND.foundcolumn)) location=0
3293  IF(location==0) THEN
3294  local_error="Row "//trim(number_to_vstring(row_indices(i),"*",err,error))//" and column "// &
3295  & trim(number_to_vstring(column_indices(j),"*",err,error))//" does not exist in the matrix."
3296  CALL flagerror(local_error,err,error,*999)
3297  ELSE
3298  matrix%DATA_L(location)=matrix%DATA_L(location).OR.values(i,j)
3299  ENDIF
3300  ENDDO !j
3301  ENDDO !i
3302  CASE DEFAULT
3303  local_error="The matrix storage type of "//trim(number_to_vstring(matrix%STORAGE_TYPE,"*",err,error))// &
3304  & " is invalid."
3305  CALL flagerror(local_error,err,error,*999)
3306  END SELECT
3307  ELSE
3308  local_error="The data type of "//trim(number_to_vstring(matrix%DATA_TYPE,"*",err,error))// &
3309  & " does not correspond to the logical data type of the given values."
3310  CALL flagerror(local_error,err,error,*999)
3311  ENDIF
3312  ELSE
3313  local_error="The size of the column indices array ("// &
3314  & trim(number_to_vstring(SIZE(column_indices,1),"*",err,error))// &
3315  & ") does not conform to the number of columns in the values array ("// &
3316  & trim(number_to_vstring(SIZE(values,2),"*",err,error))//")."
3317  CALL flagerror(local_error,err,error,*999)
3318  ENDIF
3319  ELSE
3320  local_error="The size of the row indices array ("// &
3321  & trim(number_to_vstring(SIZE(row_indices,1),"*",err,error))// &
3322  & ") does not conform to the number of rows the values array ("// &
3323  & trim(number_to_vstring(SIZE(values,1),"*",err,error))//")."
3324  CALL flagerror(local_error,err,error,*999)
3325  ENDIF
3326  ELSE
3327  CALL flagerror("The matrix has not been finished.",err,error,*999)
3328  ENDIF
3329  ELSE
3330  CALL flagerror("Matrix is not associated.",err,error,*999)
3331  ENDIF
3332 
3333  exits("MATRIX_VALUES_ADD_L2")
3334  RETURN
3335 999 errorsexits("MATRIX_VALUES_ADD_L2",err,error)
3336  RETURN 1
3337  END SUBROUTINE matrix_values_add_l2
3338 
3339  !
3340  !================================================================================================================================
3341  !
3342 
3344  SUBROUTINE matrix_values_get_intg(MATRIX,ROW_INDICES,COLUMN_INDICES,VALUES,ERR,ERROR,*)
3346  !Argument variables
3347  TYPE(matrix_type), POINTER :: MATRIX
3348  INTEGER(INTG), INTENT(IN) :: ROW_INDICES(:)
3349  INTEGER(INTG), INTENT(IN) :: COLUMN_INDICES(:)
3350  INTEGER(INTG), INTENT(OUT) :: VALUES(:)
3351  INTEGER(INTG), INTENT(OUT) :: ERR
3352  TYPE(varying_string), INTENT(OUT) :: ERROR
3353  !Local variables
3354  INTEGER(INTG) :: k,LOCATION
3355  TYPE(varying_string) :: LOCAL_ERROR
3356 
3357  enters("MATRIX_VALUES_GET_INTG",err,error,*999)
3358 
3359  IF(ASSOCIATED(matrix)) THEN
3360  IF(matrix%MATRIX_FINISHED) THEN
3361  IF(SIZE(row_indices,1)==SIZE(values,1)) THEN
3362  IF(SIZE(column_indices,1)==SIZE(values,1)) THEN
3363  IF(matrix%DATA_TYPE==matrix_vector_intg_type) THEN
3364  DO k=1,SIZE(row_indices,1)
3365  CALL matrix_storage_location_find(matrix,row_indices(k),column_indices(k),location,err,error,*999)
3366  IF(location==0) THEN
3367  values(k)=0
3368  ELSE
3369  values(k)=matrix%DATA_INTG(location)
3370  ENDIF
3371  ENDDO !k
3372  ELSE
3373  local_error="The data type of "//trim(number_to_vstring(matrix%DATA_TYPE,"*",err,error))// &
3374  & " does not correspond to the integer data type of the given values."
3375  CALL flagerror(local_error,err,error,*999)
3376  ENDIF
3377  ELSE
3378  local_error="The size of the column indices array ("// &
3379  & trim(number_to_vstring(SIZE(column_indices,1),"*",err,error))// &
3380  & ") does not conform to the size of the values array ("//trim(number_to_vstring(SIZE(values,1),"*",err,error))//")."
3381  CALL flagerror(local_error,err,error,*999)
3382  ENDIF
3383  ELSE
3384  local_error="The size of the row indices array ("// &
3385  & trim(number_to_vstring(SIZE(row_indices,1),"*",err,error))// &
3386  & ") does not conform to the size of the values array ("//trim(number_to_vstring(SIZE(values,1),"*",err,error))//")."
3387  CALL flagerror(local_error,err,error,*999)
3388  ENDIF
3389  ELSE
3390  CALL flagerror("The matrix has not been finished.",err,error,*999)
3391  ENDIF
3392  ELSE
3393  CALL flagerror("Matrix is not associated.",err,error,*999)
3394  ENDIF
3395 
3396  exits("MATRIX_VALUES_GET_INTG")
3397  RETURN
3398 999 errorsexits("MATRIX_VALUES_GET_INTG",err,error)
3399  RETURN 1
3400  END SUBROUTINE matrix_values_get_intg
3401 
3402  !
3403  !================================================================================================================================
3404  !
3405 
3407  SUBROUTINE matrix_values_get_intg1(MATRIX,ROW_INDEX,COLUMN_INDEX,VALUE,ERR,ERROR,*)
3409  !Argument variables
3410  TYPE(matrix_type), POINTER :: MATRIX
3411  INTEGER(INTG), INTENT(IN) :: ROW_INDEX
3412  INTEGER(INTG), INTENT(IN) :: COLUMN_INDEX
3413  INTEGER(INTG), INTENT(OUT) :: VALUE
3414  INTEGER(INTG), INTENT(OUT) :: ERR
3415  TYPE(varying_string), INTENT(OUT) :: ERROR
3416  !Local variables
3417  INTEGER(INTG) :: LOCATION
3418  TYPE(varying_string) :: LOCAL_ERROR
3419 
3420  enters("MATRIX_VALUES_GET_INTG1",err,error,*999)
3421 
3422  IF(ASSOCIATED(matrix)) THEN
3423  IF(matrix%MATRIX_FINISHED) THEN
3424  IF(matrix%DATA_TYPE==matrix_vector_intg_type) THEN
3425  CALL matrix_storage_location_find(matrix,row_index,column_index,location,err,error,*999)
3426  IF(location==0) THEN
3427  VALUE=0
3428  ELSE
3429  VALUE=matrix%DATA_INTG(location)
3430  ENDIF
3431  ELSE
3432  local_error="The data type of "//trim(number_to_vstring(matrix%DATA_TYPE,"*",err,error))// &
3433  & " does not correspond to the integer data type of the given value."
3434  CALL flagerror(local_error,err,error,*999)
3435  ENDIF
3436  ELSE
3437  CALL flagerror("The matrix has not been finished.",err,error,*999)
3438  ENDIF
3439  ELSE
3440  CALL flagerror("Matrix is not associated.",err,error,*999)
3441  ENDIF
3442 
3443  exits("MATRIX_VALUES_GET_INTG1")
3444  RETURN
3445 999 errorsexits("MATRIX_VALUES_GET_INTG1",err,error)
3446  RETURN 1
3447  END SUBROUTINE matrix_values_get_intg1
3448 
3449  !
3450  !================================================================================================================================
3451  !
3452 
3454  SUBROUTINE matrix_values_get_intg2(MATRIX,ROW_INDICES,COLUMN_INDICES,VALUES,ERR,ERROR,*)
3456  !Argument variables
3457  TYPE(matrix_type), POINTER :: MATRIX
3458  INTEGER(INTG), INTENT(IN) :: ROW_INDICES(:)
3459  INTEGER(INTG), INTENT(IN) :: COLUMN_INDICES(:)
3460  INTEGER(INTG), INTENT(OUT) :: VALUES(:,:)
3461  INTEGER(INTG), INTENT(OUT) :: ERR
3462  TYPE(varying_string), INTENT(OUT) :: ERROR
3463  !Local variables
3464  INTEGER(INTG) :: i,j,LOCATION
3465  TYPE(varying_string) :: LOCAL_ERROR
3466 
3467  enters("MATRIX_VALUES_GET_INTG2",err,error,*999)
3468 
3469  IF(ASSOCIATED(matrix)) THEN
3470  IF(matrix%MATRIX_FINISHED) THEN
3471  IF(SIZE(row_indices,1)==SIZE(values,1)) THEN
3472  IF(SIZE(column_indices,1)==SIZE(values,2)) THEN
3473  IF(matrix%DATA_TYPE==matrix_vector_intg_type) THEN
3474  DO i=1,SIZE(row_indices,1)
3475  DO j=1,SIZE(column_indices,1)
3476  CALL matrix_storage_location_find(matrix,row_indices(i),column_indices(j),location,err,error,*999)
3477  IF(location==0) THEN
3478  values(i,j)=0
3479  ELSE
3480  values(i,j)=matrix%DATA_INTG(location)
3481  ENDIF
3482  ENDDO !j
3483  ENDDO !i
3484  ELSE
3485  local_error="The data type of "//trim(number_to_vstring(matrix%DATA_TYPE,"*",err,error))// &
3486  & " does not correspond to the integer data type of the given values."
3487  CALL flagerror(local_error,err,error,*999)
3488  ENDIF
3489  ELSE
3490  local_error="The size of the column indices array ("// &
3491  & trim(number_to_vstring(SIZE(column_indices,1),"*",err,error))// &
3492  & ") does not conform to the number of columns in the values array ("// &
3493  & trim(number_to_vstring(SIZE(values,2),"*",err,error))//")."
3494  CALL flagerror(local_error,err,error,*999)
3495  ENDIF
3496  ELSE
3497  local_error="The size of the row indices array ("// &
3498  & trim(number_to_vstring(SIZE(row_indices,1),"*",err,error))// &
3499  & ") does not conform to the number of rows in the values array ("// &
3500  & trim(number_to_vstring(SIZE(values,1),"*",err,error))//")."
3501  CALL flagerror(local_error,err,error,*999)
3502  ENDIF
3503  ELSE
3504  CALL flagerror("The matrix has not been finished.",err,error,*999)
3505  ENDIF
3506  ELSE
3507  CALL flagerror("Matrix is not associated.",err,error,*999)
3508  ENDIF
3509 
3510  exits("MATRIX_VALUES_GET_INTG2")
3511  RETURN
3512 999 errorsexits("MATRIX_VALUES_GET_INTG2",err,error)
3513  RETURN 1
3514  END SUBROUTINE matrix_values_get_intg2
3515 
3516  !
3517  !================================================================================================================================
3518  !
3519 
3521  SUBROUTINE matrix_values_get_sp(MATRIX,ROW_INDICES,COLUMN_INDICES,VALUES,ERR,ERROR,*)
3523  !Argument variables
3524  TYPE(matrix_type), POINTER :: MATRIX
3525  INTEGER(INTG), INTENT(IN) :: ROW_INDICES(:)
3526  INTEGER(INTG), INTENT(IN) :: COLUMN_INDICES(:)
3527  REAL(SP), INTENT(OUT) :: VALUES(:)
3528  INTEGER(INTG), INTENT(OUT) :: ERR
3529  TYPE(varying_string), INTENT(OUT) :: ERROR
3530  !Local variables
3531  INTEGER(INTG) :: k,LOCATION
3532  TYPE(varying_string) :: LOCAL_ERROR
3533 
3534  enters("MATRIX_VALUES_GET_SP",err,error,*999)
3535 
3536  IF(ASSOCIATED(matrix)) THEN
3537  IF(matrix%MATRIX_FINISHED) THEN
3538  IF(SIZE(row_indices,1)==SIZE(values,1)) THEN
3539  IF(SIZE(column_indices,1)==SIZE(values,1)) THEN
3540  IF(matrix%DATA_TYPE==matrix_vector_sp_type) THEN
3541  DO k=1,SIZE(row_indices,1)
3542  CALL matrix_storage_location_find(matrix,row_indices(k),column_indices(k),location,err,error,*999)
3543  IF(location==0) THEN
3544  values(k)=0.0_sp
3545  ELSE
3546  values(k)=matrix%DATA_SP(location)
3547  ENDIF
3548  ENDDO !k
3549  ELSE
3550  local_error="The data type of "//trim(number_to_vstring(matrix%DATA_TYPE,"*",err,error))// &
3551  & " does not correspond to the single precision data type of the given values."
3552  CALL flagerror(local_error,err,error,*999)
3553  ENDIF
3554  ELSE
3555  local_error="The size of the column indices array ("// &
3556  & trim(number_to_vstring(SIZE(column_indices,1),"*",err,error))// &
3557  & ") does not conform to the size of the values array ("//trim(number_to_vstring(SIZE(values,1),"*",err,error))//")."
3558  CALL flagerror(local_error,err,error,*999)
3559  ENDIF
3560  ELSE
3561  local_error="The size of the row indices array ("// &
3562  & trim(number_to_vstring(SIZE(row_indices,1),"*",err,error))// &
3563  & ") does not conform to the size of the values array ("//trim(number_to_vstring(SIZE(values,1),"*",err,error))//")."
3564  CALL flagerror(local_error,err,error,*999)
3565  ENDIF
3566  ELSE
3567  CALL flagerror("The matrix has not been finished.",err,error,*999)
3568  ENDIF
3569  ELSE
3570  CALL flagerror("Matrix is not associated.",err,error,*999)
3571  ENDIF
3572 
3573  exits("MATRIX_VALUES_GET_SP")
3574  RETURN
3575 999 errorsexits("MATRIX_VALUES_GET_SP",err,error)
3576  RETURN 1
3577  END SUBROUTINE matrix_values_get_sp
3578 
3579  !
3580  !================================================================================================================================
3581  !
3582 
3584  SUBROUTINE matrix_values_get_sp1(MATRIX,ROW_INDEX,COLUMN_INDEX,VALUE,ERR,ERROR,*)
3586  !Argument variables
3587  TYPE(matrix_type), POINTER :: MATRIX
3588  INTEGER(INTG), INTENT(IN) :: ROW_INDEX
3589  INTEGER(INTG), INTENT(IN) :: COLUMN_INDEX
3590  REAL(SP), INTENT(OUT) :: VALUE
3591  INTEGER(INTG), INTENT(OUT) :: ERR
3592  TYPE(varying_string), INTENT(OUT) :: ERROR
3593  !Local variables
3594  INTEGER(INTG) :: LOCATION
3595  TYPE(varying_string) :: LOCAL_ERROR
3596 
3597  enters("MATRIX_VALUES_GET_SP1",err,error,*999)
3598 
3599  IF(ASSOCIATED(matrix)) THEN
3600  IF(matrix%MATRIX_FINISHED) THEN
3601  IF(matrix%DATA_TYPE==matrix_vector_sp_type) THEN
3602  CALL matrix_storage_location_find(matrix,row_index,column_index,location,err,error,*999)
3603  IF(location==0) THEN
3604  VALUE=0.0_sp
3605  ELSE
3606  VALUE=matrix%DATA_SP(location)
3607  ENDIF
3608  ELSE
3609  local_error="The data type of "//trim(number_to_vstring(matrix%DATA_TYPE,"*",err,error))// &
3610  & " does not correspond to the single precision data type of the given value."
3611  CALL flagerror(local_error,err,error,*999)
3612  ENDIF
3613  ELSE
3614  CALL flagerror("The matrix has not been finished.",err,error,*999)
3615  ENDIF
3616  ELSE
3617  CALL flagerror("Matrix is not associated.",err,error,*999)
3618  ENDIF
3619 
3620  exits("MATRIX_VALUES_GET_SP1")
3621  RETURN
3622 999 errorsexits("MATRIX_VALUES_GET_SP1",err,error)
3623  RETURN 1
3624  END SUBROUTINE matrix_values_get_sp1
3625 
3626  !
3627  !================================================================================================================================
3628  !
3629 
3631  SUBROUTINE matrix_values_get_sp2(MATRIX,ROW_INDICES,COLUMN_INDICES,VALUES,ERR,ERROR,*)
3633  !Argument variables
3634  TYPE(matrix_type), POINTER :: MATRIX
3635  INTEGER(INTG), INTENT(IN) :: ROW_INDICES(:)
3636  INTEGER(INTG), INTENT(IN) :: COLUMN_INDICES(:)
3637  REAL(SP), INTENT(OUT) :: VALUES(:,:)
3638  INTEGER(INTG), INTENT(OUT) :: ERR
3639  TYPE(varying_string), INTENT(OUT) :: ERROR
3640  !Local variables
3641  INTEGER(INTG) :: i,j,LOCATION
3642  TYPE(varying_string) :: LOCAL_ERROR
3643 
3644  enters("MATRIX_VALUES_GET_SP2",err,error,*999)
3645 
3646  IF(ASSOCIATED(matrix)) THEN
3647  IF(matrix%MATRIX_FINISHED) THEN
3648  IF(SIZE(row_indices,1)==SIZE(values,1)) THEN
3649  IF(SIZE(column_indices,1)==SIZE(values,2)) THEN
3650  IF(matrix%DATA_TYPE==matrix_vector_sp_type) THEN
3651  DO i=1,SIZE(row_indices,1)
3652  DO j=1,SIZE(column_indices,1)
3653  CALL matrix_storage_location_find(matrix,row_indices(i),column_indices(j),location,err,error,*999)
3654  IF(location==0) THEN
3655  values(i,j)=0.0_sp
3656  ELSE
3657  values(i,j)=matrix%DATA_SP(location)
3658  ENDIF
3659  ENDDO !j
3660  ENDDO !i
3661  ELSE
3662  local_error="The data type of "//trim(number_to_vstring(matrix%DATA_TYPE,"*",err,error))// &
3663  & " does not correspond to the single precision data type of the given values."
3664  CALL flagerror(local_error,err,error,*999)
3665  ENDIF
3666  ELSE
3667  local_error="The size of the column indices array ("// &
3668  & trim(number_to_vstring(SIZE(column_indices,1),"*",err,error))// &
3669  & ") does not conform to the number of columns in the values array ("// &
3670  & trim(number_to_vstring(SIZE(values,2),"*",err,error))//")."
3671  CALL flagerror(local_error,err,error,*999)
3672  ENDIF
3673  ELSE
3674  local_error="The size of the row indices array ("// &
3675  & trim(number_to_vstring(SIZE(row_indices,1),"*",err,error))// &
3676  & ") does not conform to the number of rows in the values array ("// &
3677  & trim(number_to_vstring(SIZE(values,1),"*",err,error))//")."
3678  CALL flagerror(local_error,err,error,*999)
3679  ENDIF
3680  ELSE
3681  CALL flagerror("The matrix has not been finished.",err,error,*999)
3682  ENDIF
3683  ELSE
3684  CALL flagerror("Matrix is not associated.",err,error,*999)
3685  ENDIF
3686 
3687  exits("MATRIX_VALUES_GET_SP2")
3688  RETURN
3689 999 errorsexits("MATRIX_VALUES_GET_SP2",err,error)
3690  RETURN 1
3691  END SUBROUTINE matrix_values_get_sp2
3692 
3693  !
3694  !================================================================================================================================
3695  !
3696 
3698  SUBROUTINE matrix_values_get_dp(MATRIX,ROW_INDICES,COLUMN_INDICES,VALUES,ERR,ERROR,*)
3700  !Argument variables
3701  TYPE(matrix_type), POINTER :: MATRIX
3702  INTEGER(INTG), INTENT(IN) :: ROW_INDICES(:)
3703  INTEGER(INTG), INTENT(IN) :: COLUMN_INDICES(:)
3704  REAL(DP), INTENT(OUT) :: VALUES(:)
3705  INTEGER(INTG), INTENT(OUT) :: ERR
3706  TYPE(varying_string), INTENT(OUT) :: ERROR
3707  !Local variables
3708  INTEGER(INTG) :: k,LOCATION
3709  TYPE(varying_string) :: LOCAL_ERROR
3710 
3711  enters("MATRIX_VALUES_GET_DP",err,error,*999)
3712 
3713  IF(ASSOCIATED(matrix)) THEN
3714  IF(matrix%MATRIX_FINISHED) THEN
3715  IF(SIZE(row_indices,1)==SIZE(values,1)) THEN
3716  IF(SIZE(column_indices,1)==SIZE(values,1)) THEN
3717  IF(matrix%DATA_TYPE==matrix_vector_dp_type) THEN
3718  DO k=1,SIZE(row_indices,1)
3719  CALL matrix_storage_location_find(matrix,row_indices(k),column_indices(k),location,err,error,*999)
3720  IF(location==0) THEN
3721  values(k)=0.0_dp
3722  ELSE
3723  values(k)=matrix%DATA_DP(location)
3724  ENDIF
3725  ENDDO !k
3726  ELSE
3727  local_error="The data type of "//trim(number_to_vstring(matrix%DATA_TYPE,"*",err,error))// &
3728  & " does not correspond to the double precision data type of the given values."
3729  CALL flagerror(local_error,err,error,*999)
3730  ENDIF
3731  ELSE
3732  local_error="The size of the column indices array ("// &
3733  & trim(number_to_vstring(SIZE(column_indices,1),"*",err,error))// &
3734  & ") does not conform to the size of the values array ("//trim(number_to_vstring(SIZE(values,1),"*",err,error))//")."
3735  CALL flagerror(local_error,err,error,*999)
3736  ENDIF
3737  ELSE
3738  local_error="The size of the row indices array ("// &
3739  & trim(number_to_vstring(SIZE(row_indices,1),"*",err,error))// &
3740  & ") does not conform to the size of the values array ("//trim(number_to_vstring(SIZE(values,1),"*",err,error))//")."
3741  CALL flagerror(local_error,err,error,*999)
3742  ENDIF
3743  ELSE
3744  CALL flagerror("The matrix has not been finished.",err,error,*999)
3745  ENDIF
3746  ELSE
3747  CALL flagerror("Matrix is not associated.",err,error,*999)
3748  ENDIF
3749 
3750  exits("MATRIX_VALUES_GET_DP")
3751  RETURN
3752 999 errorsexits("MATRIX_VALUES_GET_DP",err,error)
3753  RETURN 1
3754  END SUBROUTINE matrix_values_get_dp
3755 
3756  !
3757  !================================================================================================================================
3758  !
3759 
3761  SUBROUTINE matrix_values_get_dp1(MATRIX,ROW_INDEX,COLUMN_INDEX,VALUE,ERR,ERROR,*)
3763  !Argument variables
3764  TYPE(matrix_type), POINTER :: MATRIX
3765  INTEGER(INTG), INTENT(IN) :: ROW_INDEX
3766  INTEGER(INTG), INTENT(IN) :: COLUMN_INDEX
3767  REAL(DP), INTENT(OUT) :: VALUE
3768  INTEGER(INTG), INTENT(OUT) :: ERR
3769  TYPE(varying_string), INTENT(OUT) :: ERROR
3770  !Local variables
3771  INTEGER(INTG) :: LOCATION
3772  TYPE(varying_string) :: LOCAL_ERROR
3773 
3774  enters("MATRIX_VALUES_GET_DP1",err,error,*999)
3775 
3776  IF(ASSOCIATED(matrix)) THEN
3777  IF(matrix%MATRIX_FINISHED) THEN
3778  IF(matrix%DATA_TYPE==matrix_vector_dp_type) THEN
3779  CALL matrix_storage_location_find(matrix,row_index,column_index,location,err,error,*999)
3780  IF(location==0) THEN
3781  VALUE=0.0_dp
3782  ELSE
3783  VALUE=matrix%DATA_DP(location)
3784  ENDIF
3785  ELSE
3786  local_error="The data type of "//trim(number_to_vstring(matrix%DATA_TYPE,"*",err,error))// &
3787  & " does not correspond to the double precision data type of the given value."
3788  CALL flagerror(local_error,err,error,*999)
3789  ENDIF
3790  ELSE
3791  CALL flagerror("The matrix has not been finished.",err,error,*999)
3792  ENDIF
3793  ELSE
3794  CALL flagerror("Matrix is not associated.",err,error,*999)
3795  ENDIF
3796 
3797  exits("MATRIX_VALUES_GET_DP1")
3798  RETURN
3799 999 errorsexits("MATRIX_VALUES_GET_DP1",err,error)
3800  RETURN 1
3801  END SUBROUTINE matrix_values_get_dp1
3802 
3803  !
3804  !================================================================================================================================
3805  !
3806 
3808  SUBROUTINE matrix_values_get_dp2(MATRIX,ROW_INDICES,COLUMN_INDICES,VALUES,ERR,ERROR,*)
3810  !Argument variables
3811  TYPE(matrix_type), POINTER :: MATRIX
3812  INTEGER(INTG), INTENT(IN) :: ROW_INDICES(:)
3813  INTEGER(INTG), INTENT(IN) :: COLUMN_INDICES(:)
3814  REAL(DP), INTENT(OUT) :: VALUES(:,:)
3815  INTEGER(INTG), INTENT(OUT) :: ERR
3816  TYPE(varying_string), INTENT(OUT) :: ERROR
3817  !Local variables
3818  INTEGER(INTG) :: i,j,LOCATION
3819  TYPE(varying_string) :: LOCAL_ERROR
3820 
3821  enters("MATRIX_VALUES_GET_DP2",err,error,*999)
3822 
3823  IF(ASSOCIATED(matrix)) THEN
3824  IF(matrix%MATRIX_FINISHED) THEN
3825  IF(SIZE(row_indices,1)==SIZE(values,1)) THEN
3826  IF(SIZE(column_indices,1)==SIZE(values,2)) THEN
3827  IF(matrix%DATA_TYPE==matrix_vector_dp_type) THEN
3828  DO i=1,SIZE(row_indices,1)
3829  DO j=1,SIZE(column_indices,1)
3830  CALL matrix_storage_location_find(matrix,row_indices(i),column_indices(j),location,err,error,*999)
3831  IF(location==0) THEN
3832  values(i,j)=0.0_dp
3833  ELSE
3834  values(i,j)=matrix%DATA_DP(location)
3835  ENDIF
3836  ENDDO !j
3837  ENDDO !i
3838  ELSE
3839  local_error="The data type of "//trim(number_to_vstring(matrix%DATA_TYPE,"*",err,error))// &
3840  & " does not correspond to the double precision data type of the given values."
3841  CALL flagerror(local_error,err,error,*999)
3842  ENDIF
3843  ELSE
3844  local_error="The size of the column indices array ("// &
3845  & trim(number_to_vstring(SIZE(column_indices,1),"*",err,error))// &
3846  & ") does not conform to the number of columns in the values array ("// &
3847  & trim(number_to_vstring(SIZE(values,2),"*",err,error))//")."
3848  CALL flagerror(local_error,err,error,*999)
3849  ENDIF
3850  ELSE
3851  local_error="The size of the row indices array ("// &
3852  & trim(number_to_vstring(SIZE(row_indices,1),"*",err,error))// &
3853  & ") does not conform to the number of rows in the values array ("// &
3854  & trim(number_to_vstring(SIZE(values,1),"*",err,error))//")."
3855  CALL flagerror(local_error,err,error,*999)
3856  ENDIF
3857  ELSE
3858  CALL flagerror("The matrix has not been finished.",err,error,*999)
3859  ENDIF
3860  ELSE
3861  CALL flagerror("Matrix is not associated.",err,error,*999)
3862  ENDIF
3863 
3864  exits("MATRIX_VALUES_GET_DP2")
3865  RETURN
3866 999 errorsexits("MATRIX_VALUES_GET_DP2",err,error)
3867  RETURN 1
3868  END SUBROUTINE matrix_values_get_dp2
3869 
3870  !
3871  !================================================================================================================================
3872  !
3873 
3875  SUBROUTINE matrix_values_get_l(MATRIX,ROW_INDICES,COLUMN_INDICES,VALUES,ERR,ERROR,*)
3877  !Argument variables
3878  TYPE(matrix_type), POINTER :: MATRIX
3879  INTEGER(INTG), INTENT(IN) :: ROW_INDICES(:)
3880  INTEGER(INTG), INTENT(IN) :: COLUMN_INDICES(:)
3881  LOGICAL, INTENT(OUT) :: VALUES(:)
3882  INTEGER(INTG), INTENT(OUT) :: ERR
3883  TYPE(varying_string), INTENT(OUT) :: ERROR
3884  !Local variables
3885  INTEGER(INTG) :: k,LOCATION
3886  TYPE(varying_string) :: LOCAL_ERROR
3887 
3888  enters("MATRIX_VALUES_GET_L",err,error,*999)
3889 
3890  IF(ASSOCIATED(matrix)) THEN
3891  IF(matrix%MATRIX_FINISHED) THEN
3892  IF(SIZE(row_indices,1)==SIZE(values,1)) THEN
3893  IF(SIZE(column_indices,1)==SIZE(values,1)) THEN
3894  IF(matrix%DATA_TYPE==matrix_vector_l_type) THEN
3895  DO k=1,SIZE(row_indices,1)
3896  CALL matrix_storage_location_find(matrix,row_indices(k),column_indices(k),location,err,error,*999)
3897  IF(location==0) THEN
3898  values(k)=.false.
3899  ELSE
3900  values(k)=matrix%DATA_L(location)
3901  ENDIF
3902  ENDDO !k
3903  ELSE
3904  local_error="The data type of "//trim(number_to_vstring(matrix%DATA_TYPE,"*",err,error))// &
3905  & " does not correspond to the logical data type of the given values."
3906  CALL flagerror(local_error,err,error,*999)
3907  ENDIF
3908  ELSE
3909  local_error="The size of the column indices array ("// &
3910  & trim(number_to_vstring(SIZE(column_indices,1),"*",err,error))// &
3911  & ") does not conform to the size of the values array ("//trim(number_to_vstring(SIZE(values,1),"*",err,error))//")."
3912  CALL flagerror(local_error,err,error,*999)
3913  ENDIF
3914  ELSE
3915  local_error="The size of the row indices array ("// &
3916  & trim(number_to_vstring(SIZE(row_indices,1),"*",err,error))// &
3917  & ") does not conform to the size of the values array ("//trim(number_to_vstring(SIZE(values,1),"*",err,error))//")."
3918  CALL flagerror(local_error,err,error,*999)
3919  ENDIF
3920  ELSE
3921  CALL flagerror("The matrix has not been finished.",err,error,*999)
3922  ENDIF
3923  ELSE
3924  CALL flagerror("Matrix is not associated.",err,error,*999)
3925  ENDIF
3926 
3927  exits("MATRIX_VALUES_GET_L")
3928  RETURN
3929 999 errorsexits("MATRIX_VALUES_GET_L",err,error)
3930  RETURN 1
3931  END SUBROUTINE matrix_values_get_l
3932 
3933  !
3934  !================================================================================================================================
3935  !
3936 
3938  SUBROUTINE matrix_values_get_l1(MATRIX,ROW_INDEX,COLUMN_INDEX,VALUE,ERR,ERROR,*)
3940  !Argument variables
3941  TYPE(matrix_type), POINTER :: MATRIX
3942  INTEGER(INTG), INTENT(IN) :: ROW_INDEX
3943  INTEGER(INTG), INTENT(IN) :: COLUMN_INDEX
3944  LOGICAL, INTENT(OUT) :: VALUE
3945  INTEGER(INTG), INTENT(OUT) :: ERR
3946  TYPE(varying_string), INTENT(OUT) :: ERROR
3947  !Local variables
3948  INTEGER(INTG) :: LOCATION
3949  TYPE(varying_string) :: LOCAL_ERROR
3950 
3951  enters("MATRIX_VALUES_GET_L1",err,error,*999)
3952 
3953  IF(ASSOCIATED(matrix)) THEN
3954  IF(matrix%MATRIX_FINISHED) THEN
3955  IF(matrix%DATA_TYPE==matrix_vector_l_type) THEN
3956  CALL matrix_storage_location_find(matrix,row_index,column_index,location,err,error,*999)
3957  IF(location==0) THEN
3958  VALUE=.false.
3959  ELSE
3960  VALUE=matrix%DATA_L(location)
3961  ENDIF
3962  ELSE
3963  local_error="The data type of "//trim(number_to_vstring(matrix%DATA_TYPE,"*",err,error))// &
3964  & " does not correspond to the logical data type of the given value."
3965  CALL flagerror(local_error,err,error,*999)
3966  ENDIF
3967  ELSE
3968  CALL flagerror("The matrix has not been finished.",err,error,*999)
3969  ENDIF
3970  ELSE
3971  CALL flagerror("Matrix is not associated.",err,error,*999)
3972  ENDIF
3973 
3974  exits("MATRIX_VALUES_GET_L1")
3975  RETURN
3976 999 errorsexits("MATRIX_VALUES_GET_L1",err,error)
3977  RETURN 1
3978  END SUBROUTINE matrix_values_get_l1
3979 
3980  !
3981  !================================================================================================================================
3982  !
3983 
3985  SUBROUTINE matrix_values_get_l2(MATRIX,ROW_INDICES,COLUMN_INDICES,VALUES,ERR,ERROR,*)
3987  !Argument variables
3988  TYPE(matrix_type), POINTER :: MATRIX
3989  INTEGER(INTG), INTENT(IN) :: ROW_INDICES(:)
3990  INTEGER(INTG), INTENT(IN) :: COLUMN_INDICES(:)
3991  LOGICAL, INTENT(OUT) :: VALUES(:,:)
3992  INTEGER(INTG), INTENT(OUT) :: ERR
3993  TYPE(varying_string), INTENT(OUT) :: ERROR
3994  !Local variables
3995  INTEGER(INTG) :: i,j,LOCATION
3996  TYPE(varying_string) :: LOCAL_ERROR
3997 
3998  enters("MATRIX_VALUES_GET_L2",err,error,*999)
3999 
4000  IF(ASSOCIATED(matrix)) THEN
4001  IF(matrix%MATRIX_FINISHED) THEN
4002  IF(SIZE(row_indices,1)==SIZE(values,1)) THEN
4003  IF(SIZE(column_indices,1)==SIZE(values,2)) THEN
4004  IF(matrix%DATA_TYPE==matrix_vector_l_type) THEN
4005  DO i=1,SIZE(row_indices,1)
4006  DO j=1,SIZE(column_indices,1)
4007  CALL matrix_storage_location_find(matrix,row_indices(i),column_indices(j),location,err,error,*999)
4008  IF(location==0) THEN
4009  values(i,j)=.false.
4010  ELSE
4011  values(i,j)=matrix%DATA_L(location)
4012  ENDIF
4013  ENDDO !j
4014  ENDDO !i
4015  ELSE
4016  local_error="The data type of "//trim(number_to_vstring(matrix%DATA_TYPE,"*",err,error))// &
4017  & " does not correspond to the logical data type of the given values."
4018  CALL flagerror(local_error,err,error,*999)
4019  ENDIF
4020  ELSE
4021  local_error="The size of the column indices array ("// &
4022  & trim(number_to_vstring(SIZE(column_indices,1),"*",err,error))// &
4023  & ") does not conform to the number of columns in the values array ("// &
4024  & trim(number_to_vstring(SIZE(values,2),"*",err,error))//")."
4025  CALL flagerror(local_error,err,error,*999)
4026  ENDIF
4027  ELSE
4028  local_error="The size of the row indices array ("// &
4029  & trim(number_to_vstring(SIZE(row_indices,1),"*",err,error))// &
4030  & ") does not conform to the number of rows in the values array ("// &
4031  & trim(number_to_vstring(SIZE(values,1),"*",err,error))//")."
4032  CALL flagerror(local_error,err,error,*999)
4033  ENDIF
4034  ELSE
4035  CALL flagerror("The matrix has not been finished.",err,error,*999)
4036  ENDIF
4037  ELSE
4038  CALL flagerror("Matrix is not associated.",err,error,*999)
4039  ENDIF
4040 
4041  exits("MATRIX_VALUES_GET_L2")
4042  RETURN
4043 999 errorsexits("MATRIX_VALUES_GET_L2",err,error)
4044  RETURN 1
4045  END SUBROUTINE matrix_values_get_l2
4046 
4047  !
4048  !================================================================================================================================
4049  !
4050 
4052  SUBROUTINE matrix_values_set_intg(MATRIX,ROW_INDICES,COLUMN_INDICES,VALUES,ERR,ERROR,*)
4054  !Argument variables
4055  TYPE(matrix_type), POINTER :: MATRIX
4056  INTEGER(INTG), INTENT(IN) :: ROW_INDICES(:)
4057  INTEGER(INTG), INTENT(IN) :: COLUMN_INDICES(:)
4058  INTEGER(INTG), INTENT(IN) :: VALUES(:)
4059  INTEGER(INTG), INTENT(OUT) :: ERR
4060  TYPE(varying_string), INTENT(OUT) :: ERROR
4061  !Local variables
4062  INTEGER(INTG) :: k,LOCATION
4063  TYPE(varying_string) :: LOCAL_ERROR
4064 
4065  enters("MATRIX_VALUES_SET_INTG",err,error,*999)
4066 
4067  IF(ASSOCIATED(matrix)) THEN
4068  IF(matrix%MATRIX_FINISHED) THEN
4069  IF(SIZE(row_indices,1)==SIZE(values,1)) THEN
4070  IF(SIZE(column_indices,1)==SIZE(values,1)) THEN
4071  IF(matrix%DATA_TYPE==matrix_vector_intg_type) THEN
4072  DO k=1,SIZE(row_indices,1)
4073  CALL matrix_storage_location_find(matrix,row_indices(k),column_indices(k),location,err,error,*999)
4074  IF(location==0) THEN
4075  local_error="Row "//trim(number_to_vstring(row_indices(k),"*",err,error))//" and column "// &
4076  & trim(number_to_vstring(column_indices(k),"*",err,error))//" does not exist in the matrix."
4077  CALL flagerror(local_error,err,error,*999)
4078  ELSE
4079  matrix%DATA_INTG(location)=values(k)
4080  ENDIF
4081  ENDDO !k
4082  ELSE
4083  local_error="The data type of "//trim(number_to_vstring(matrix%DATA_TYPE,"*",err,error))// &
4084  & " does not correspond to the integer data type of the given values."
4085  CALL flagerror(local_error,err,error,*999)
4086  ENDIF
4087  ELSE
4088  local_error="The size of the column indices array ("// &
4089  & trim(number_to_vstring(SIZE(column_indices,1),"*",err,error))// &
4090  & ") does not conform to the size of the values array ("//trim(number_to_vstring(SIZE(values,1),"*",err,error))//")."
4091  CALL flagerror(local_error,err,error,*999)
4092  ENDIF
4093  ELSE
4094  local_error="The size of the row indices array ("// &
4095  & trim(number_to_vstring(SIZE(row_indices,1),"*",err,error))// &
4096  & ") does not conform to the size of the values array ("//trim(number_to_vstring(SIZE(values,1),"*",err,error))//")."
4097  CALL flagerror(local_error,err,error,*999)
4098  ENDIF
4099  ELSE
4100  CALL flagerror("The matrix has not been finished.",err,error,*999)
4101  ENDIF
4102  ELSE
4103  CALL flagerror("Matrix is not associated.",err,error,*999)
4104  ENDIF
4105 
4106  exits("MATRIX_VALUES_SET_INTG")
4107  RETURN
4108 999 errorsexits("MATRIX_VALUES_SET_INTG",err,error)
4109  RETURN 1
4110  END SUBROUTINE matrix_values_set_intg
4111 
4112  !
4113  !================================================================================================================================
4114  !
4115 
4117  SUBROUTINE matrix_values_set_intg1(MATRIX,ROW_INDEX,COLUMN_INDEX,VALUE,ERR,ERROR,*)
4119  !Argument variables
4120  TYPE(matrix_type), POINTER :: MATRIX
4121  INTEGER(INTG), INTENT(IN) :: ROW_INDEX
4122  INTEGER(INTG), INTENT(IN) :: COLUMN_INDEX
4123  INTEGER(INTG), INTENT(IN) :: VALUE
4124  INTEGER(INTG), INTENT(OUT) :: ERR
4125  TYPE(varying_string), INTENT(OUT) :: ERROR
4126  !Local variables
4127  INTEGER(INTG) :: LOCATION
4128  TYPE(varying_string) :: LOCAL_ERROR
4129 
4130  enters("MATRIX_VALUES_SET_INTG1",err,error,*999)
4131 
4132  IF(ASSOCIATED(matrix)) THEN
4133  IF(matrix%MATRIX_FINISHED) THEN
4134  IF(matrix%DATA_TYPE==matrix_vector_intg_type) THEN
4135  CALL matrix_storage_location_find(matrix,row_index,column_index,location,err,error,*999)
4136  IF(location==0) THEN
4137  local_error="Row "//trim(number_to_vstring(row_index,"*",err,error))//" and column "// &
4138  & trim(number_to_vstring(column_index,"*",err,error))//" does not exist in the matrix."
4139  CALL flagerror(local_error,err,error,*999)
4140  ELSE
4141  matrix%DATA_INTG(location)=VALUE
4142  ENDIF
4143  ELSE
4144  local_error="The data type of "//trim(number_to_vstring(matrix%DATA_TYPE,"*",err,error))// &
4145  & " does not correspond to the integer data type of the given value."
4146  CALL flagerror(local_error,err,error,*999)
4147  ENDIF
4148  ELSE
4149  CALL flagerror("The matrix has not been finished.",err,error,*999)
4150  ENDIF
4151  ELSE
4152  CALL flagerror("Matrix is not associated.",err,error,*999)
4153  ENDIF
4154 
4155  exits("MATRIX_VALUES_SET_INTG1")
4156  RETURN
4157 999 errorsexits("MATRIX_VALUES_SET_INTG1",err,error)
4158  RETURN 1
4159  END SUBROUTINE matrix_values_set_intg1
4160 
4161  !
4162  !================================================================================================================================
4163  !
4164 
4166  SUBROUTINE matrix_values_set_intg2(MATRIX,ROW_INDICES,COLUMN_INDICES,VALUES,ERR,ERROR,*)
4168  !Argument variables
4169  TYPE(matrix_type), POINTER :: MATRIX
4170  INTEGER(INTG), INTENT(IN) :: ROW_INDICES(:)
4171  INTEGER(INTG), INTENT(IN) :: COLUMN_INDICES(:)
4172  INTEGER(INTG), INTENT(IN) :: VALUES(:,:)
4173  INTEGER(INTG), INTENT(OUT) :: ERR
4174  TYPE(varying_string), INTENT(OUT) :: ERROR
4175  !Local variables
4176  INTEGER(INTG) :: i,j,LOCATION
4177  TYPE(varying_string) :: LOCAL_ERROR
4178 
4179  enters("MATRIX_VALUES_SET_INTG2",err,error,*999)
4180 
4181  IF(ASSOCIATED(matrix)) THEN
4182  IF(matrix%MATRIX_FINISHED) THEN
4183  IF(SIZE(row_indices,1)==SIZE(values,1)) THEN
4184  IF(SIZE(column_indices,1)==SIZE(values,2)) THEN
4185  IF(matrix%DATA_TYPE==matrix_vector_intg_type) THEN
4186  DO i=1,SIZE(row_indices,1)
4187  DO j=1,SIZE(column_indices,1)
4188  CALL matrix_storage_location_find(matrix,row_indices(i),column_indices(j),location,err,error,*999)
4189  IF(location==0) THEN
4190  local_error="Row "//trim(number_to_vstring(row_indices(i),"*",err,error))//" and column "// &
4191  & trim(number_to_vstring(column_indices(j),"*",err,error))//" does not exist in the matrix."
4192  CALL flagerror(local_error,err,error,*999)
4193  ELSE
4194  matrix%DATA_INTG(location)=values(i,j)
4195  ENDIF
4196  ENDDO !j
4197  ENDDO !i
4198  ELSE
4199  local_error="The data type of "//trim(number_to_vstring(matrix%DATA_TYPE,"*",err,error))// &
4200  & " does not correspond to the integer data type of the given values."
4201  CALL flagerror(local_error,err,error,*999)
4202  ENDIF
4203  ELSE
4204  local_error="The size of the column indices array ("// &
4205  & trim(number_to_vstring(SIZE(column_indices,1),"*",err,error))// &
4206  & ") does not conform to the number of columns in the values array ("// &
4207  & trim(number_to_vstring(SIZE(values,2),"*",err,error))//")."
4208  CALL flagerror(local_error,err,error,*999)
4209  ENDIF
4210  ELSE
4211  local_error="The size of the row indices array ("// &
4212  & trim(number_to_vstring(SIZE(row_indices,1),"*",err,error))// &
4213  & ") does not conform to the number of rows in the values array ("// &
4214  & trim(number_to_vstring(SIZE(values,1),"*",err,error))//")."
4215  CALL flagerror(local_error,err,error,*999)
4216  ENDIF
4217  ELSE
4218  CALL flagerror("The matrix has not been finished.",err,error,*999)
4219  ENDIF
4220  ELSE
4221  CALL flagerror("Matrix is not associated.",err,error,*999)
4222  ENDIF
4223 
4224  exits("MATRIX_VALUES_SET_INTG2")
4225  RETURN
4226 999 errorsexits("MATRIX_VALUES_SET_INTG2",err,error)
4227  RETURN 1
4228  END SUBROUTINE matrix_values_set_intg2
4229 
4230  !
4231  !================================================================================================================================
4232  !
4233 
4235  SUBROUTINE matrix_values_set_sp(MATRIX,ROW_INDICES,COLUMN_INDICES,VALUES,ERR,ERROR,*)
4237  !Argument variables
4238  TYPE(matrix_type), POINTER :: MATRIX
4239  INTEGER(INTG), INTENT(IN) :: ROW_INDICES(:)
4240  INTEGER(INTG), INTENT(IN) :: COLUMN_INDICES(:)
4241  REAL(SP), INTENT(IN) :: VALUES(:)
4242  INTEGER(INTG), INTENT(OUT) :: ERR
4243  TYPE(varying_string), INTENT(OUT) :: ERROR
4244  !Local variables
4245  INTEGER(INTG) :: k,LOCATION
4246  TYPE(varying_string) :: LOCAL_ERROR
4247 
4248  enters("MATRIX_VALUES_SET_SP",err,error,*999)
4249 
4250  IF(ASSOCIATED(matrix)) THEN
4251  IF(matrix%MATRIX_FINISHED) THEN
4252  IF(SIZE(row_indices,1)==SIZE(values,1)) THEN
4253  IF(SIZE(column_indices,1)==SIZE(values,1)) THEN
4254  IF(matrix%DATA_TYPE==matrix_vector_sp_type) THEN
4255  DO k=1,SIZE(row_indices,1)
4256  CALL matrix_storage_location_find(matrix,row_indices(k),column_indices(k),location,err,error,*999)
4257  IF(location==0) THEN
4258  local_error="Row "//trim(number_to_vstring(row_indices(k),"*",err,error))//" and column "// &
4259  & trim(number_to_vstring(column_indices(k),"*",err,error))//" does not exist in the matrix."
4260  CALL flagerror(local_error,err,error,*999)
4261  ELSE
4262  matrix%DATA_SP(location)=values(k)
4263  ENDIF
4264  ENDDO !k
4265  ELSE
4266  local_error="The data type of "//trim(number_to_vstring(matrix%DATA_TYPE,"*",err,error))// &
4267  & " does not correspond to the single precision data type of the given values."
4268  CALL flagerror(local_error,err,error,*999)
4269  ENDIF
4270  ELSE
4271  local_error="The size of the column indices array ("// &
4272  & trim(number_to_vstring(SIZE(column_indices,1),"*",err,error))// &
4273  & ") does not conform to the size of the values array ("//trim(number_to_vstring(SIZE(values,1),"*",err,error))//")."
4274  CALL flagerror(local_error,err,error,*999)
4275  ENDIF
4276  ELSE
4277  local_error="The size of the row indices array ("// &
4278  & trim(number_to_vstring(SIZE(row_indices,1),"*",err,error))// &
4279  & ") does not conform to the size of the values array ("//trim(number_to_vstring(SIZE(values,1),"*",err,error))//")."
4280  CALL flagerror(local_error,err,error,*999)
4281  ENDIF
4282  ELSE
4283  CALL flagerror("The matrix has not been finished.",err,error,*999)
4284  ENDIF
4285  ELSE
4286  CALL flagerror("Matrix is not associated.",err,error,*999)
4287  ENDIF
4288 
4289  exits("MATRIX_VALUES_SET_SP")
4290  RETURN
4291 999 errorsexits("MATRIX_VALUES_SET_SP",err,error)
4292  RETURN 1
4293  END SUBROUTINE matrix_values_set_sp
4294 
4295  !
4296  !================================================================================================================================
4297  !
4298 
4300  SUBROUTINE matrix_values_set_sp1(MATRIX,ROW_INDEX,COLUMN_INDEX,VALUE,ERR,ERROR,*)
4302  !Argument variables
4303  TYPE(matrix_type), POINTER :: MATRIX
4304  INTEGER(INTG), INTENT(IN) :: ROW_INDEX
4305  INTEGER(INTG), INTENT(IN) :: COLUMN_INDEX
4306  REAL(SP), INTENT(IN) :: VALUE
4307  INTEGER(INTG), INTENT(OUT) :: ERR
4308  TYPE(varying_string), INTENT(OUT) :: ERROR
4309  !Local variables
4310  INTEGER(INTG) :: LOCATION
4311  TYPE(varying_string) :: LOCAL_ERROR
4312 
4313  enters("MATRIX_VALUES_SET_SP1",err,error,*999)
4314 
4315  IF(ASSOCIATED(matrix)) THEN
4316  IF(matrix%MATRIX_FINISHED) THEN
4317  IF(matrix%DATA_TYPE==matrix_vector_sp_type) THEN
4318  CALL matrix_storage_location_find(matrix,row_index,column_index,location,err,error,*999)
4319  IF(location==0) THEN
4320  local_error="Row "//trim(number_to_vstring(row_index,"*",err,error))//" and column "// &
4321  & trim(number_to_vstring(column_index,"*",err,error))//" does not exist in the matrix."
4322  CALL flagerror(local_error,err,error,*999)
4323  ELSE
4324  matrix%DATA_SP(location)=VALUE
4325  ENDIF
4326  ELSE
4327  local_error="The data type of "//trim(number_to_vstring(matrix%DATA_TYPE,"*",err,error))// &
4328  & " does not correspond to the single precision data type of the given value."
4329  CALL flagerror(local_error,err,error,*999)
4330  ENDIF
4331  ELSE
4332  CALL flagerror("The matrix has not been finished.",err,error,*999)
4333  ENDIF
4334  ELSE
4335  CALL flagerror("Matrix is not associated.",err,error,*999)
4336  ENDIF
4337 
4338  exits("MATRIX_VALUES_SET_SP1")
4339  RETURN
4340 999 errorsexits("MATRIX_VALUES_SET_SP1",err,error)
4341  RETURN 1
4342  END SUBROUTINE matrix_values_set_sp1
4343 
4344  !
4345  !================================================================================================================================
4346  !
4347 
4349  SUBROUTINE matrix_values_set_sp2(MATRIX,ROW_INDICES,COLUMN_INDICES,VALUES,ERR,ERROR,*)
4351  !Argument variables
4352  TYPE(matrix_type), POINTER :: MATRIX
4353  INTEGER(INTG), INTENT(IN) :: ROW_INDICES(:)
4354  INTEGER(INTG), INTENT(IN) :: COLUMN_INDICES(:)
4355  REAL(SP), INTENT(IN) :: VALUES(:,:)
4356  INTEGER(INTG), INTENT(OUT) :: ERR
4357  TYPE(varying_string), INTENT(OUT) :: ERROR
4358  !Local variables
4359  INTEGER(INTG) :: i,j,LOCATION
4360  TYPE(varying_string) :: LOCAL_ERROR
4361 
4362  enters("MATRIX_VALUES_SET_SP2",err,error,*999)
4363 
4364  IF(ASSOCIATED(matrix)) THEN
4365  IF(matrix%MATRIX_FINISHED) THEN
4366  IF(SIZE(row_indices,1)==SIZE(values,1)) THEN
4367  IF(SIZE(column_indices,1)==SIZE(values,2)) THEN
4368  IF(matrix%DATA_TYPE==matrix_vector_sp_type) THEN
4369  DO i=1,SIZE(row_indices,1)
4370  DO j=1,SIZE(column_indices,1)
4371  CALL matrix_storage_location_find(matrix,row_indices(i),column_indices(j),location,err,error,*999)
4372  IF(location==0) THEN
4373  local_error="Row "//trim(number_to_vstring(row_indices(i),"*",err,error))//" and column "// &
4374  & trim(number_to_vstring(column_indices(j),"*",err,error))//" does not exist in the matrix."
4375  CALL flagerror(local_error,err,error,*999)
4376  ELSE
4377  matrix%DATA_SP(location)=values(i,j)
4378  ENDIF
4379  ENDDO !j
4380  ENDDO !i
4381  ELSE
4382  local_error="The data type of "//trim(number_to_vstring(matrix%DATA_TYPE,"*",err,error))// &
4383  & " does not correspond to the single precision data type of the given values."
4384  CALL flagerror(local_error,err,error,*999)
4385  ENDIF
4386  ELSE
4387  local_error="The size of the column indices array ("// &
4388  & trim(number_to_vstring(SIZE(column_indices,1),"*",err,error))// &
4389  & ") does not conform to the number of columns in the values array ("// &
4390  & trim(number_to_vstring(SIZE(values,2),"*",err,error))//")."
4391  CALL flagerror(local_error,err,error,*999)
4392  ENDIF
4393  ELSE
4394  local_error="The size of the row indices array ("// &
4395  & trim(number_to_vstring(SIZE(row_indices,1),"*",err,error))// &
4396  & ") does not conform to the number of rows in the values array ("// &
4397  & trim(number_to_vstring(SIZE(values,1),"*",err,error))//")."
4398  CALL flagerror(local_error,err,error,*999)
4399  ENDIF
4400  ELSE
4401  CALL flagerror("The matrix has not been finished.",err,error,*999)
4402  ENDIF
4403  ELSE
4404  CALL flagerror("Matrix is not associated.",err,error,*999)
4405  ENDIF
4406 
4407  exits("MATRIX_VALUES_SET_SP2")
4408  RETURN
4409 999 errorsexits("MATRIX_VALUES_SET_SP2",err,error)
4410  RETURN 1
4411  END SUBROUTINE matrix_values_set_sp2
4412 
4413  !
4414  !================================================================================================================================
4415  !
4416 
4418  SUBROUTINE matrix_values_set_dp(MATRIX,ROW_INDICES,COLUMN_INDICES,VALUES,ERR,ERROR,*)
4420  !Argument variables
4421  TYPE(matrix_type), POINTER :: MATRIX
4422  INTEGER(INTG), INTENT(IN) :: ROW_INDICES(:)
4423  INTEGER(INTG), INTENT(IN) :: COLUMN_INDICES(:)
4424  REAL(DP), INTENT(IN) :: VALUES(:)
4425  INTEGER(INTG), INTENT(OUT) :: ERR
4426  TYPE(varying_string), INTENT(OUT) :: ERROR
4427  !Local variables
4428  INTEGER(INTG) :: k,LOCATION
4429  TYPE(varying_string) :: LOCAL_ERROR
4430 
4431  enters("MATRIX_VALUES_SET_DP",err,error,*999)
4432 
4433  IF(ASSOCIATED(matrix)) THEN
4434  IF(matrix%MATRIX_FINISHED) THEN
4435  IF(SIZE(row_indices,1)==SIZE(values,1)) THEN
4436  IF(SIZE(column_indices,1)==SIZE(values,1)) THEN
4437  IF(matrix%DATA_TYPE==matrix_vector_dp_type) THEN
4438  DO k=1,SIZE(row_indices,1)
4439  CALL matrix_storage_location_find(matrix,row_indices(k),column_indices(k),location,err,error,*999)
4440  IF(location==0) THEN
4441  local_error="Row "//trim(number_to_vstring(row_indices(k),"*",err,error))//" and column "// &
4442  & trim(number_to_vstring(column_indices(k),"*",err,error))//" does not exist in the matrix."
4443  CALL flagerror(local_error,err,error,*999)
4444  ELSE
4445  matrix%DATA_DP(location)=values(k)
4446  ENDIF
4447  ENDDO !k
4448  ELSE
4449  local_error="The data type of "//trim(number_to_vstring(matrix%DATA_TYPE,"*",err,error))// &
4450  & " does not correspond to the double precision data type of the given values."
4451  CALL flagerror(local_error,err,error,*999)
4452  ENDIF
4453  ELSE
4454  local_error="The size of the column indices array ("// &
4455  & trim(number_to_vstring(SIZE(column_indices,1),"*",err,error))// &
4456  & ") does not conform to the size of the values array ("//trim(number_to_vstring(SIZE(values,1),"*",err,error))//")."
4457  CALL flagerror(local_error,err,error,*999)
4458  ENDIF
4459  ELSE
4460  local_error="The size of the row indices array ("// &
4461  & trim(number_to_vstring(SIZE(row_indices,1),"*",err,error))// &
4462  & ") does not conform to the size of the values array ("//trim(number_to_vstring(SIZE(values,1),"*",err,error))//")."
4463  CALL flagerror(local_error,err,error,*999)
4464  ENDIF
4465  ELSE
4466  CALL flagerror("The matrix has not been finished.",err,error,*999)
4467  ENDIF
4468  ELSE
4469  CALL flagerror("Matrix is not associated.",err,error,*999)
4470  ENDIF
4471 
4472  exits("MATRIX_VALUES_SET_DP")
4473  RETURN
4474 999 errorsexits("MATRIX_VALUES_SET_DP",err,error)
4475  RETURN 1
4476  END SUBROUTINE matrix_values_set_dp
4477 
4478  !
4479  !================================================================================================================================
4480  !
4481 
4483  SUBROUTINE matrix_values_set_dp1(MATRIX,ROW_INDEX,COLUMN_INDEX,VALUE,ERR,ERROR,*)
4485  !Argument variables
4486  TYPE(matrix_type), POINTER :: MATRIX
4487  INTEGER(INTG), INTENT(IN) :: ROW_INDEX
4488  INTEGER(INTG), INTENT(IN) :: COLUMN_INDEX
4489  REAL(DP), INTENT(IN) :: VALUE
4490  INTEGER(INTG), INTENT(OUT) :: ERR
4491  TYPE(varying_string), INTENT(OUT) :: ERROR
4492  !Local variables
4493  INTEGER(INTG) :: LOCATION
4494  TYPE(varying_string) :: LOCAL_ERROR
4495 
4496  enters("MATRIX_VALUES_SET_DP1",err,error,*999)
4497 
4498  IF(ASSOCIATED(matrix)) THEN
4499  IF(matrix%MATRIX_FINISHED) THEN
4500  IF(matrix%DATA_TYPE==matrix_vector_dp_type) THEN
4501  CALL matrix_storage_location_find(matrix,row_index,column_index,location,err,error,*999)
4502  IF(location==0) THEN
4503  local_error="Row "//trim(number_to_vstring(row_index,"*",err,error))//" and column "// &
4504  & trim(number_to_vstring(column_index,"*",err,error))//" does not exist in the matrix."
4505  CALL flagerror(local_error,err,error,*999)
4506  ELSE
4507  matrix%DATA_DP(location)=VALUE
4508  ENDIF
4509  ELSE
4510  local_error="The data type of "//trim(number_to_vstring(matrix%DATA_TYPE,"*",err,error))// &
4511  & " does not correspond to the double precision data type of the given value."
4512  CALL flagerror(local_error,err,error,*999)
4513  ENDIF
4514  ELSE
4515  CALL flagerror("The matrix has not been finished.",err,error,*999)
4516  ENDIF
4517  ELSE
4518  CALL flagerror("Matrix is not associated.",err,error,*999)
4519  ENDIF
4520 
4521  exits("MATRIX_VALUES_SET_DP1")
4522  RETURN
4523 999 errorsexits("MATRIX_VALUES_SET_DP1",err,error)
4524  RETURN 1
4525  END SUBROUTINE matrix_values_set_dp1
4526 
4527  !
4528  !================================================================================================================================
4529  !
4530 
4532  SUBROUTINE matrix_values_set_dp2(MATRIX,ROW_INDICES,COLUMN_INDICES,VALUES,ERR,ERROR,*)
4534  !Argument variables
4535  TYPE(matrix_type), POINTER :: MATRIX
4536  INTEGER(INTG), INTENT(IN) :: ROW_INDICES(:)
4537  INTEGER(INTG), INTENT(IN) :: COLUMN_INDICES(:)
4538  REAL(DP), INTENT(IN) :: VALUES(:,:)
4539  INTEGER(INTG), INTENT(OUT) :: ERR
4540  TYPE(varying_string), INTENT(OUT) :: ERROR
4541  !Local variables
4542  INTEGER(INTG) :: i,j,LOCATION
4543  TYPE(varying_string) :: LOCAL_ERROR
4544 
4545  enters("MATRIX_VALUES_SET_DP2",err,error,*999)
4546 
4547  IF(ASSOCIATED(matrix)) THEN
4548  IF(matrix%MATRIX_FINISHED) THEN
4549  IF(SIZE(row_indices,1)==SIZE(values,1)) THEN
4550  IF(SIZE(column_indices,1)==SIZE(values,2)) THEN
4551  IF(matrix%DATA_TYPE==matrix_vector_dp_type) THEN
4552  DO i=1,SIZE(row_indices,1)
4553  DO j=1,SIZE(column_indices,1)
4554  CALL matrix_storage_location_find(matrix,row_indices(i),column_indices(j),location,err,error,*999)
4555  IF(location==0) THEN
4556  local_error="Row "//trim(number_to_vstring(row_indices(i),"*",err,error))//" and column "// &
4557  & trim(number_to_vstring(column_indices(j),"*",err,error))//" does not exist in the matrix."
4558  CALL flagerror(local_error,err,error,*999)
4559  ELSE
4560  matrix%DATA_DP(location)=values(i,j)
4561  ENDIF
4562  ENDDO !j
4563  ENDDO !i
4564  ELSE
4565  local_error="The data type of "//trim(number_to_vstring(matrix%DATA_TYPE,"*",err,error))// &
4566  & " does not correspond to the double precision data type of the given values."
4567  CALL flagerror(local_error,err,error,*999)
4568  ENDIF
4569  ELSE
4570  local_error="The size of the column indices array ("// &
4571  & trim(number_to_vstring(SIZE(column_indices,1),"*",err,error))// &
4572  & ") does not conform to the number of columns in the values array ("// &
4573  & trim(number_to_vstring(SIZE(values,2),"*",err,error))//")."
4574  CALL flagerror(local_error,err,error,*999)
4575  ENDIF
4576  ELSE
4577  local_error="The size of the row indices array ("// &
4578  & trim(number_to_vstring(SIZE(row_indices,1),"*",err,error))// &
4579  & ") does not conform to the number of rows in the values array ("// &
4580  & trim(number_to_vstring(SIZE(values,1),"*",err,error))//")."
4581  CALL flagerror(local_error,err,error,*999)
4582  ENDIF
4583  ELSE
4584  CALL flagerror("The matrix has not been finished.",err,error,*999)
4585  ENDIF
4586  ELSE
4587  CALL flagerror("Matrix is not associated.",err,error,*999)
4588  ENDIF
4589 
4590  exits("MATRIX_VALUES_SET_DP2")
4591  RETURN
4592 999 errorsexits("MATRIX_VALUES_SET_DP2",err,error)
4593  RETURN 1
4594  END SUBROUTINE matrix_values_set_dp2
4595 
4596  !
4597  !================================================================================================================================
4598  !
4599 
4601  SUBROUTINE matrix_values_set_l(MATRIX,ROW_INDICES,COLUMN_INDICES,VALUES,ERR,ERROR,*)
4603  !Argument variables
4604  TYPE(matrix_type), POINTER :: MATRIX
4605  INTEGER(INTG), INTENT(IN) :: ROW_INDICES(:)
4606  INTEGER(INTG), INTENT(IN) :: COLUMN_INDICES(:)
4607  LOGICAL, INTENT(IN) :: VALUES(:)
4608  INTEGER(INTG), INTENT(OUT) :: ERR
4609  TYPE(varying_string), INTENT(OUT) :: ERROR
4610  !Local variables
4611  INTEGER(INTG) :: k,LOCATION
4612  TYPE(varying_string) :: LOCAL_ERROR
4613 
4614  enters("MATRIX_VALUES_SET_L",err,error,*999)
4615 
4616  IF(ASSOCIATED(matrix)) THEN
4617  IF(matrix%MATRIX_FINISHED) THEN
4618  IF(SIZE(row_indices,1)==SIZE(values,1)) THEN
4619  IF(SIZE(column_indices,1)==SIZE(values,1)) THEN
4620  IF(matrix%DATA_TYPE==matrix_vector_l_type) THEN
4621  DO k=1,SIZE(row_indices,1)
4622  CALL matrix_storage_location_find(matrix,row_indices(k),column_indices(k),location,err,error,*999)
4623  IF(location==0) THEN
4624  local_error="Row "//trim(number_to_vstring(row_indices(k),"*",err,error))//" and column "// &
4625  & trim(number_to_vstring(column_indices(k),"*",err,error))//" does not exist in the matrix."
4626  CALL flagerror(local_error,err,error,*999)
4627  ELSE
4628  matrix%DATA_L(location)=values(k)
4629  ENDIF
4630  ENDDO !k
4631  ELSE
4632  local_error="The data type of "//trim(number_to_vstring(matrix%DATA_TYPE,"*",err,error))// &
4633  & " does not correspond to the logical data type of the given values."
4634  CALL flagerror(local_error,err,error,*999)
4635  ENDIF
4636  ELSE
4637  local_error="The size of the column indices array ("// &
4638  & trim(number_to_vstring(SIZE(column_indices,1),"*",err,error))// &
4639  & ") does not conform to the size of the values array ("//trim(number_to_vstring(SIZE(values,1),"*",err,error))//")."
4640  CALL flagerror(local_error,err,error,*999)
4641  ENDIF
4642  ELSE
4643  local_error="The size of the row indices array ("// &
4644  & trim(number_to_vstring(SIZE(row_indices,1),"*",err,error))// &
4645  & ") does not conform to the size of the values array ("//trim(number_to_vstring(SIZE(values,1),"*",err,error))//")."
4646  CALL flagerror(local_error,err,error,*999)
4647  ENDIF
4648  ELSE
4649  CALL flagerror("The matrix has not been finished.",err,error,*999)
4650  ENDIF
4651  ELSE
4652  CALL flagerror("Matrix is not associated.",err,error,*999)
4653  ENDIF
4654 
4655  exits("MATRIX_VALUES_SET_L")
4656  RETURN
4657 999 errorsexits("MATRIX_VALUES_SET_L",err,error)
4658  RETURN 1
4659  END SUBROUTINE matrix_values_set_l
4660 
4661  !
4662  !================================================================================================================================
4663  !
4664 
4666  SUBROUTINE matrix_values_set_l1(MATRIX,ROW_INDEX,COLUMN_INDEX,VALUE,ERR,ERROR,*)
4668  !Argument variables
4669  TYPE(matrix_type), POINTER :: MATRIX
4670  INTEGER(INTG), INTENT(IN) :: ROW_INDEX
4671  INTEGER(INTG), INTENT(IN) :: COLUMN_INDEX
4672  LOGICAL, INTENT(IN) :: VALUE
4673  INTEGER(INTG), INTENT(OUT) :: ERR
4674  TYPE(varying_string), INTENT(OUT) :: ERROR
4675  !Local variables
4676  INTEGER(INTG) :: LOCATION
4677  TYPE(varying_string) :: LOCAL_ERROR
4678 
4679  enters("MATRIX_VALUES_SET_L1",err,error,*999)
4680 
4681  IF(ASSOCIATED(matrix)) THEN
4682  IF(matrix%MATRIX_FINISHED) THEN
4683  IF(matrix%DATA_TYPE==matrix_vector_l_type) THEN
4684  CALL matrix_storage_location_find(matrix,row_index,column_index,location,err,error,*999)
4685  IF(location==0) THEN
4686  local_error="Row "//trim(number_to_vstring(row_index,"*",err,error))//" and column "// &
4687  & trim(number_to_vstring(column_index,"*",err,error))//" does not exist in the matrix."
4688  CALL flagerror(local_error,err,error,*999)
4689  ELSE
4690  matrix%DATA_L(location)=VALUE
4691  ENDIF
4692  ELSE
4693  local_error="The data type of "//trim(number_to_vstring(matrix%DATA_TYPE,"*",err,error))// &
4694  & " does not correspond to the logical data type of the given value."
4695  CALL flagerror(local_error,err,error,*999)
4696  ENDIF
4697  ELSE
4698  CALL flagerror("The matrix has not been finished.",err,error,*999)
4699  ENDIF
4700  ELSE
4701  CALL flagerror("Matrix is not associated.",err,error,*999)
4702  ENDIF
4703 
4704  exits("MATRIX_VALUES_SET_L1")
4705  RETURN
4706 999 errorsexits("MATRIX_VALUES_SET_L1",err,error)
4707  RETURN 1
4708  END SUBROUTINE matrix_values_set_l1
4709 
4710  !
4711  !================================================================================================================================
4712  !
4713 
4715  SUBROUTINE matrix_values_set_l2(MATRIX,ROW_INDICES,COLUMN_INDICES,VALUES,ERR,ERROR,*)
4717  !Argument variables
4718  TYPE(matrix_type), POINTER :: MATRIX
4719  INTEGER(INTG), INTENT(IN) :: ROW_INDICES(:)
4720  INTEGER(INTG), INTENT(IN) :: COLUMN_INDICES(:)
4721  LOGICAL, INTENT(IN) :: VALUES(:,:)
4722  INTEGER(INTG), INTENT(OUT) :: ERR
4723  TYPE(varying_string), INTENT(OUT) :: ERROR
4724  !Local variables
4725  INTEGER(INTG) :: i,j,LOCATION
4726  TYPE(varying_string) :: LOCAL_ERROR
4727 
4728  enters("MATRIX_VALUES_SET_L2",err,error,*999)
4729 
4730  IF(ASSOCIATED(matrix)) THEN
4731  IF(matrix%MATRIX_FINISHED) THEN
4732  IF(SIZE(row_indices,1)==SIZE(values,1)) THEN
4733  IF(SIZE(column_indices,1)==SIZE(values,2)) THEN
4734  IF(matrix%DATA_TYPE==matrix_vector_l_type) THEN
4735  DO i=1,SIZE(row_indices,1)
4736  DO j=1,SIZE(row_indices,1)
4737  CALL matrix_storage_location_find(matrix,row_indices(i),column_indices(j),location,err,error,*999)
4738  IF(location==0) THEN
4739  local_error="Row "//trim(number_to_vstring(row_indices(i),"*",err,error))//" and column "// &
4740  & trim(number_to_vstring(column_indices(j),"*",err,error))//" does not exist in the matrix."
4741  CALL flagerror(local_error,err,error,*999)
4742  ELSE
4743  matrix%DATA_L(location)=values(i,j)
4744  ENDIF
4745  ENDDO !j
4746  ENDDO !i
4747  ELSE
4748  local_error="The data type of "//trim(number_to_vstring(matrix%DATA_TYPE,"*",err,error))// &
4749  & " does not correspond to the logical data type of the given values."
4750  CALL flagerror(local_error,err,error,*999)
4751  ENDIF
4752  ELSE
4753  local_error="The size of the column indices array ("// &
4754  & trim(number_to_vstring(SIZE(column_indices,1),"*",err,error))// &
4755  & ") does not conform to the number of columns in the values array ("// &
4756  & trim(number_to_vstring(SIZE(values,2),"*",err,error))//")."
4757  CALL flagerror(local_error,err,error,*999)
4758  ENDIF
4759  ELSE
4760  local_error="The size of the row indices array ("// &
4761  & trim(number_to_vstring(SIZE(row_indices,1),"*",err,error))// &
4762  & ") does not conform to the number of rows in the values array ("// &
4763  & trim(number_to_vstring(SIZE(values,1),"*",err,error))//")."
4764  CALL flagerror(local_error,err,error,*999)
4765  ENDIF
4766  ELSE
4767  CALL flagerror("The matrix has not been finished.",err,error,*999)
4768  ENDIF
4769  ELSE
4770  CALL flagerror("Matrix is not associated.",err,error,*999)
4771  ENDIF
4772 
4773  exits("MATRIX_VALUES_SET_L2")
4774  RETURN
4775 999 errorsexits("MATRIX_VALUES_SET_L2",err,error)
4776  RETURN 1
4777  END SUBROUTINE matrix_values_set_l2
4778 
4779  !
4780  !================================================================================================================================
4781  !
4782 
4784  SUBROUTINE vector_all_values_set_intg(VECTOR,VALUE,ERR,ERROR,*)
4786  !Argument variables
4787  TYPE(vector_type), POINTER :: VECTOR
4788  INTEGER(INTG), INTENT(IN) :: VALUE
4789  INTEGER(INTG), INTENT(OUT) :: ERR
4790  TYPE(varying_string), INTENT(OUT) :: ERROR
4791  !Local variables
4792  TYPE(varying_string) :: LOCAL_ERROR
4793 
4794  enters("VECTOR_ALL_VALUES_SET_INTG",err,error,*999)
4795 
4796  IF(ASSOCIATED(vector)) THEN
4797  IF(vector%VECTOR_FINISHED) THEN
4798  IF(vector%DATA_TYPE==matrix_vector_intg_type) THEN
4799  vector%DATA_INTG=VALUE
4800  ELSE
4801  local_error="The data type of "//trim(number_to_vstring(vector%DATA_TYPE,"*",err,error))// &
4802  & " does not correspond to the integer data type of the given value."
4803  CALL flagerror(local_error,err,error,*999)
4804  ENDIF
4805  ELSE
4806  CALL flagerror("The vector has not been finished.",err,error,*999)
4807  ENDIF
4808  ELSE
4809  CALL flagerror("Vector is not associated.",err,error,*999)
4810  ENDIF
4811 
4812  exits("VECTOR_ALL_VALUES_SET_INTG")
4813  RETURN
4814 999 errorsexits("VECTOR_ALL_VALUES_SET_INTG",err,error)
4815  RETURN 1
4816  END SUBROUTINE vector_all_values_set_intg
4817 
4818  !
4819  !================================================================================================================================
4820  !
4821 
4823  SUBROUTINE vector_all_values_set_sp(VECTOR,VALUE,ERR,ERROR,*)
4825  !Argument variables
4826  TYPE(vector_type), POINTER :: VECTOR
4827  REAL(SP), INTENT(IN) :: VALUE
4828  INTEGER(INTG), INTENT(OUT) :: ERR
4829  TYPE(varying_string), INTENT(OUT) :: ERROR
4830  !Local variables
4831  TYPE(varying_string) :: LOCAL_ERROR
4832 
4833  enters("VECTOR_ALL_VALUES_SET_SP",err,error,*999)
4834 
4835  IF(ASSOCIATED(vector)) THEN
4836  IF(vector%VECTOR_FINISHED) THEN
4837  IF(vector%DATA_TYPE==matrix_vector_sp_type) THEN
4838  vector%DATA_SP=VALUE
4839  ELSE
4840  local_error="The data type of "//trim(number_to_vstring(vector%DATA_TYPE,"*",err,error))// &
4841  & " does not correspond to the single precision data type of the given value."
4842  CALL flagerror(local_error,err,error,*999)
4843  ENDIF
4844  ELSE
4845  CALL flagerror("The vector has not been finished.",err,error,*999)
4846  ENDIF
4847  ELSE
4848  CALL flagerror("Vector is not associated.",err,error,*999)
4849  ENDIF
4850 
4851  exits("VECTOR_ALL_VALUES_SET_SP")
4852  RETURN
4853 999 errorsexits("VECTOR_ALL_VALUES_SET_SP",err,error)
4854  RETURN 1
4855  END SUBROUTINE vector_all_values_set_sp
4856 
4857  !
4858  !================================================================================================================================
4859  !
4860 
4862  SUBROUTINE vector_all_values_set_dp(VECTOR,VALUE,ERR,ERROR,*)
4864  !Argument variables
4865  TYPE(vector_type), POINTER :: VECTOR
4866  REAL(DP), INTENT(IN) :: VALUE
4867  INTEGER(INTG), INTENT(OUT) :: ERR
4868  TYPE(varying_string), INTENT(OUT) :: ERROR
4869  !Local variables
4870  TYPE(varying_string) :: LOCAL_ERROR
4871 
4872  enters("VECTOR_ALL_VALUES_SET_DP",err,error,*999)
4873 
4874  IF(ASSOCIATED(vector)) THEN
4875  IF(vector%VECTOR_FINISHED) THEN
4876  IF(vector%DATA_TYPE==matrix_vector_dp_type) THEN
4877  vector%DATA_DP=VALUE
4878  ELSE
4879  local_error="The data type of "//trim(number_to_vstring(vector%DATA_TYPE,"*",err,error))// &
4880  & " does not correspond to the double precision data type of the given value."
4881  CALL flagerror(local_error,err,error,*999)
4882  ENDIF
4883  ELSE
4884  CALL flagerror("The vector has not been finished.",err,error,*999)
4885  ENDIF
4886  ELSE
4887  CALL flagerror("Vector is not associated.",err,error,*999)
4888  ENDIF
4889 
4890  exits("VECTOR_ALL_VALUES_SET_DP")
4891  RETURN
4892 999 errorsexits("VECTOR_ALL_VALUES_SET_DP",err,error)
4893  RETURN 1
4894  END SUBROUTINE vector_all_values_set_dp
4895 
4896  !
4897  !================================================================================================================================
4898  !
4899 
4901  SUBROUTINE vector_all_values_set_l(VECTOR,VALUE,ERR,ERROR,*)
4903  !Argument variables
4904  TYPE(vector_type), POINTER :: VECTOR
4905  LOGICAL, INTENT(IN) :: VALUE
4906  INTEGER(INTG), INTENT(OUT) :: ERR
4907  TYPE(varying_string), INTENT(OUT) :: ERROR
4908  !Local variables
4909  TYPE(varying_string) :: LOCAL_ERROR
4910 
4911  enters("VECTOR_ALL_VALUES_SET_L",err,error,*999)
4912 
4913  IF(ASSOCIATED(vector)) THEN
4914  IF(vector%VECTOR_FINISHED) THEN
4915  IF(vector%DATA_TYPE==matrix_vector_l_type) THEN
4916  vector%DATA_L=VALUE
4917  ELSE
4918  local_error="The data type of "//trim(number_to_vstring(vector%DATA_TYPE,"*",err,error))// &
4919  & " does not correspond to the logical data type of the given value."
4920  CALL flagerror(local_error,err,error,*999)
4921  ENDIF
4922  ELSE
4923  CALL flagerror("The vector has not been finished.",err,error,*999)
4924  ENDIF
4925  ELSE
4926  CALL flagerror("Vector is not associated.",err,error,*999)
4927  ENDIF
4928 
4929  exits("VECTOR_ALL_VALUES_SET_L")
4930  RETURN
4931 999 errorsexits("VECTOR_ALL_VALUES_SET_L",err,error)
4932  RETURN 1
4933  END SUBROUTINE vector_all_values_set_l
4934 
4935  !
4936  !================================================================================================================================
4937  !
4938 
4940  SUBROUTINE vector_create_finish(VECTOR,ERR,ERROR,*)
4942  !Argument variables
4943  TYPE(vector_type), POINTER :: VECTOR
4944  INTEGER(INTG), INTENT(OUT) :: ERR
4945  TYPE(varying_string), INTENT(OUT) :: ERROR
4946  !Local Variables
4947  TYPE(varying_string) :: LOCAL_ERROR
4948 
4949  enters("VECTOR_CREATE_FINISH",err,error,*999)
4950 
4951  IF(ASSOCIATED(vector)) THEN
4952  IF(vector%VECTOR_FINISHED) THEN
4953  CALL flagerror("Vector has been finished.",err,error,*999)
4954  ELSE
4955  IF(vector%SIZE>0) THEN
4956  SELECT CASE(vector%DATA_TYPE)
4958  ALLOCATE(vector%DATA_INTG(vector%SIZE),stat=err)
4959  IF(err/=0) CALL flagerror("Could not allocate vector integer data.",err,error,*999)
4960  CASE(matrix_vector_sp_type)
4961  ALLOCATE(vector%DATA_SP(vector%SIZE),stat=err)
4962  IF(err/=0) CALL flagerror("Could not allocate vector single precision data.",err,error,*999)
4963  CASE(matrix_vector_dp_type)
4964  ALLOCATE(vector%DATA_DP(vector%SIZE),stat=err)
4965  IF(err/=0) CALL flagerror("Could not allocate vector double precision data.",err,error,*999)
4966  CASE(matrix_vector_l_type)
4967  ALLOCATE(vector%DATA_L(vector%SIZE),stat=err)
4968  IF(err/=0) CALL flagerror("Could not allocate vector logical data.",err,error,*999)
4969  CASE DEFAULT
4970  local_error="The vector data type of "//trim(number_to_vstring(vector%DATA_TYPE,"*",err,error))//" is invalid."
4971  CALL flagerror(local_error,err,error,*999)
4972  END SELECT
4973  ENDIF
4974  vector%ID=matrix_vector_id
4976  vector%VECTOR_FINISHED=.true.
4977  ENDIF
4978  ELSE
4979  CALL flagerror("Vector is not associated.",err,error,*999)
4980  ENDIF
4981 
4982  exits("VECTOR_CREATE_FINISH")
4983  RETURN
4984 999 errorsexits("VECTOR_CREATE_FINISH",err,error)
4985  RETURN 1
4986  END SUBROUTINE vector_create_finish
4987 
4988  !
4989  !================================================================================================================================
4990  !
4991 
4993  SUBROUTINE vector_create_start(VECTOR,ERR,ERROR,*)
4995  !Argument variables
4996  TYPE(vector_type), POINTER :: VECTOR
4997  INTEGER(INTG), INTENT(OUT) :: ERR
4998  TYPE(varying_string), INTENT(OUT) :: ERROR
4999  !Local Variables
5000 
5001  enters("VECTOR_CREATE_START",err,error,*999)
5002 
5003  IF(ASSOCIATED(vector)) THEN
5004  CALL flagerror("Vector is already associated.",err,error,*998)
5005  ELSE
5006  ALLOCATE(vector,stat=err)
5007  IF(err/=0) CALL flagerror("Could not allocate the vector.",err,error,*999)
5008  CALL vector_initialise(vector,err,error,*999)
5009  !Set the defaults
5010  vector%DATA_TYPE=matrix_vector_dp_type
5011  ENDIF
5012 
5013  exits("VECTOR_CREATE_START")
5014  RETURN
5015 999 IF(ASSOCIATED(vector)) CALL vector_finalise(vector,err,error,*998)
5016 998 errorsexits("VECTOR_CREATE_START",err,error)
5017  RETURN 1
5018  END SUBROUTINE vector_create_start
5019 
5020  !
5021  !================================================================================================================================
5022  !
5023 
5025  SUBROUTINE vector_data_get_intg(VECTOR,DATA,ERR,ERROR,*)
5027  !Argument variables
5028  TYPE(vector_type), POINTER :: VECTOR
5029  INTEGER(INTG), POINTER :: DATA(:)
5030  INTEGER(INTG), INTENT(OUT) :: ERR
5031  TYPE(varying_string), INTENT(OUT) :: ERROR
5032  !Local Variables
5033  TYPE(varying_string) :: LOCAL_ERROR
5034 
5035  enters("VECTOR_DATA_GET_INTG",err,error,*999)
5036 
5037  IF(ASSOCIATED(vector)) THEN
5038  IF(ASSOCIATED(data)) THEN
5039  CALL flagerror("Data is already associated.",err,error,*999)
5040  ELSE
5041  NULLIFY(data)
5042  IF(vector%VECTOR_FINISHED) THEN
5043  IF(vector%DATA_TYPE==matrix_vector_intg_type) THEN
5044  data=>vector%DATA_INTG
5045  ELSE
5046  local_error="The data type of "//trim(number_to_vstring(vector%DATA_TYPE,"*",err,error))// &
5047  & " does not correspond to the integer data type of the requested values."
5048  CALL flagerror(local_error,err,error,*999)
5049  ENDIF
5050  ELSE
5051  CALL flagerror("The vector has not been finished.",err,error,*999)
5052  ENDIF
5053  ENDIF
5054  ELSE
5055  CALL flagerror("Vector is not associated.",err,error,*999)
5056  ENDIF
5057 
5058  exits("VECTOR_DATA_GET_INTG")
5059  RETURN
5060 999 errorsexits("VECTOR_DATA_GET_INTG",err,error)
5061  RETURN 1
5062  END SUBROUTINE vector_data_get_intg
5063 
5064  !
5065  !================================================================================================================================
5066  !
5067 
5069  SUBROUTINE vector_data_get_sp(VECTOR,DATA,ERR,ERROR,*)
5071  !Argument variables
5072  TYPE(vector_type), POINTER :: VECTOR
5073  REAL(SP), POINTER :: DATA(:)
5074  INTEGER(INTG), INTENT(OUT) :: ERR
5075  TYPE(varying_string), INTENT(OUT) :: ERROR
5076  !Local Variables
5077  TYPE(varying_string) :: LOCAL_ERROR
5078 
5079  enters("VECTOR_DATA_GET_SP",err,error,*999)
5080 
5081  IF(ASSOCIATED(vector)) THEN
5082  IF(ASSOCIATED(data)) THEN
5083  CALL flagerror("Data is already associated.",err,error,*999)
5084  ELSE
5085  NULLIFY(data)
5086  IF(vector%VECTOR_FINISHED) THEN
5087  IF(vector%DATA_TYPE==matrix_vector_sp_type) THEN
5088  data=>vector%DATA_SP
5089  ELSE
5090  local_error="The data type of "//trim(number_to_vstring(vector%DATA_TYPE,"*",err,error))// &
5091  & " does not correspond to the single precision data type of the requested values."
5092  CALL flagerror(local_error,err,error,*999)
5093  ENDIF
5094  ELSE
5095  CALL flagerror("The vector has not been finished.",err,error,*999)
5096  ENDIF
5097  ENDIF
5098  ELSE
5099  CALL flagerror("Vector is not associated.",err,error,*999)
5100  ENDIF
5101 
5102  exits("VECTOR_DATA_GET_SP")
5103  RETURN
5104 999 errorsexits("VECTOR_DATA_GET_SP",err,error)
5105  RETURN 1
5106  END SUBROUTINE vector_data_get_sp
5107 
5108  !
5109  !================================================================================================================================
5110  !
5111 
5113  SUBROUTINE vector_data_get_dp(VECTOR,DATA,ERR,ERROR,*)
5115  !Argument variables
5116  TYPE(vector_type), POINTER :: VECTOR
5117  REAL(DP), POINTER :: DATA(:)
5118  INTEGER(INTG), INTENT(OUT) :: ERR
5119  TYPE(varying_string), INTENT(OUT) :: ERROR
5120  !Local Variables
5121  TYPE(varying_string) :: LOCAL_ERROR
5122 
5123  enters("VECTOR_DATA_GET_DP",err,error,*999)
5124 
5125  IF(ASSOCIATED(vector)) THEN
5126  IF(ASSOCIATED(data)) THEN
5127  CALL flagerror("Data is already associated.",err,error,*999)
5128  ELSE
5129  NULLIFY(data)
5130  IF(vector%VECTOR_FINISHED) THEN
5131  IF(vector%DATA_TYPE==matrix_vector_dp_type) THEN
5132  data=>vector%DATA_DP
5133  ELSE
5134  local_error="The data type of "//trim(number_to_vstring(vector%DATA_TYPE,"*",err,error))// &
5135  & " does not correspond to the double precision data type of the requested values."
5136  CALL flagerror(local_error,err,error,*999)
5137  ENDIF
5138  ELSE
5139  CALL flagerror("The vector has not been finished.",err,error,*999)
5140  ENDIF
5141  ENDIF
5142  ELSE
5143  CALL flagerror("Vector is not associated.",err,error,*999)
5144  ENDIF
5145 
5146  exits("VECTOR_DATA_GET_DP")
5147  RETURN
5148 999 errorsexits("VECTOR_DATA_GET_DP",err,error)
5149  RETURN 1
5150  END SUBROUTINE vector_data_get_dp
5151 
5152  !
5153  !================================================================================================================================
5154  !
5155 
5157  SUBROUTINE vector_data_get_l(VECTOR,DATA,ERR,ERROR,*)
5159  !Argument variables
5160  TYPE(vector_type), POINTER :: VECTOR
5161  LOGICAL, POINTER :: DATA(:)
5162  INTEGER(INTG), INTENT(OUT) :: ERR
5163  TYPE(varying_string), INTENT(OUT) :: ERROR
5164  !Local Variables
5165  TYPE(varying_string) :: LOCAL_ERROR
5166 
5167  enters("VECTOR_DATA_GET_L",err,error,*999)
5168 
5169  IF(ASSOCIATED(vector)) THEN
5170  IF(ASSOCIATED(data)) THEN
5171  CALL flagerror("Data is already associated.",err,error,*999)
5172  ELSE
5173  NULLIFY(data)
5174  IF(vector%VECTOR_FINISHED) THEN
5175  IF(vector%DATA_TYPE==matrix_vector_l_type) THEN
5176  data=>vector%DATA_L
5177  ELSE
5178  local_error="The data type of "//trim(number_to_vstring(vector%DATA_TYPE,"*",err,error))// &
5179  & " does not correspond to the logical data type of the requested values."
5180  CALL flagerror(local_error,err,error,*999)
5181  ENDIF
5182  ELSE
5183  CALL flagerror("The vector has not been finished.",err,error,*999)
5184  ENDIF
5185  ENDIF
5186  ELSE
5187  CALL flagerror("Vector is not associated.",err,error,*999)
5188  ENDIF
5189 
5190  exits("VECTOR_DATA_GET_L")
5191  RETURN
5192 999 errorsexits("VECTOR_DATA_GET_L",err,error)
5193  RETURN 1
5194  END SUBROUTINE vector_data_get_l
5195 
5196  !
5197  !================================================================================================================================
5198  !
5199 
5201  SUBROUTINE vector_datatypeget(vector,dataType,err,error,*)
5203  !Argument variables
5204  TYPE(vector_type), POINTER :: vector
5205  INTEGER(INTG), INTENT(OUT) :: dataType
5206  INTEGER(INTG), INTENT(OUT) :: err
5207  TYPE(varying_string), INTENT(OUT) :: error
5208 
5209  enters("Vector_DataTypeGet",err,error,*999)
5210 
5211  IF(ASSOCIATED(vector)) THEN
5212  IF(.NOT.vector%vector_finished) THEN
5213  CALL flag_error("The vector has not been finished.",err,error,*999)
5214  ELSE
5215  datatype=vector%data_type
5216  END IF
5217  ELSE
5218  CALL flag_error("Vector is not associated.",err,error,*999)
5219  END IF
5220 
5221  exits("Vector_DataTypeGet")
5222  RETURN
5223 999 errorsexits("Vector_DataTypeGet",err,error)
5224  RETURN 1
5225  END SUBROUTINE vector_datatypeget
5226 
5227  !
5228  !================================================================================================================================
5229  !
5230 
5232  SUBROUTINE vector_data_type_set(VECTOR,DATA_TYPE,ERR,ERROR,*)
5234  !Argument variables
5235  TYPE(vector_type), POINTER :: VECTOR
5236  INTEGER(INTG), INTENT(IN) :: DATA_TYPE
5237  INTEGER(INTG), INTENT(OUT) :: ERR
5238  TYPE(varying_string), INTENT(OUT) :: ERROR
5239  !Local Variables
5240  TYPE(varying_string) :: LOCAL_ERROR
5241 
5242  enters("VECTOR_DATA_TYPE_SET",err,error,*999)
5243 
5244  IF(ASSOCIATED(vector)) THEN
5245  IF(vector%VECTOR_FINISHED) THEN
5246  CALL flagerror("The vector has been finished.",err,error,*999)
5247  ELSE
5248  SELECT CASE(data_type)
5250  vector%DATA_TYPE=matrix_vector_intg_type
5251  CASE(matrix_vector_sp_type)
5252  vector%DATA_TYPE=matrix_vector_sp_type
5253  CASE(matrix_vector_dp_type)
5254  vector%DATA_TYPE=matrix_vector_dp_type
5255  CASE(matrix_vector_l_type)
5256  vector%DATA_TYPE=matrix_vector_l_type
5257  CASE DEFAULT
5258  local_error="The vector data type of "//trim(number_to_vstring(data_type,"*",err,error))//" is invalid."
5259  CALL flagerror(local_error,err,error,*999)
5260  END SELECT
5261  ENDIF
5262  ELSE
5263  CALL flagerror("Vector is not associated.",err,error,*999)
5264  ENDIF
5265 
5266  exits("VECTOR_DATA_TYPE_SET")
5267  RETURN
5268 999 errorsexits("VECTOR_DATA_TYPE_SET",err,error)
5269  RETURN 1
5270  END SUBROUTINE vector_data_type_set
5271 
5272  !
5273  !================================================================================================================================
5274  !
5275 
5277  SUBROUTINE vector_destroy(VECTOR,ERR,ERROR,*)
5279  !Argument variables
5280  TYPE(vector_type), POINTER :: VECTOR
5281  INTEGER(INTG), INTENT(OUT) :: ERR
5282  TYPE(varying_string), INTENT(OUT) :: ERROR
5283  !Local Variables
5284 
5285  enters("VECTOR_DESTROY",err,error,*999)
5286 
5287  IF(ASSOCIATED(vector)) THEN
5288  CALL vector_finalise(vector,err,error,*999)
5289  ELSE
5290  CALL flagerror("Vector is not associated.",err,error,*999)
5291  ENDIF
5292 
5293  exits("VECTOR_DESTROY")
5294  RETURN
5295 999 errorsexits("VECTOR_DESTROY",err,error)
5296  RETURN 1
5297  END SUBROUTINE vector_destroy
5298 
5299  !
5300  !================================================================================================================================
5301  !
5302 
5304  SUBROUTINE vector_duplicate(VECTOR,NEW_VECTOR,ERR,ERROR,*)
5306  !Argument variables
5307  TYPE(vector_type), POINTER :: VECTOR
5308  TYPE(vector_type), POINTER :: NEW_VECTOR
5309  INTEGER(INTG), INTENT(OUT) :: ERR
5310  TYPE(varying_string), INTENT(OUT) :: ERROR
5311  !Local Variables
5312 
5313  enters("VECTOR_DUPLICATE",err,error,*998)
5314 
5315  IF(ASSOCIATED(vector)) THEN
5316  IF(ASSOCIATED(new_vector)) THEN
5317  CALL flagerror("New vector is already associated.",err,error,*998)
5318  ELSE
5319  CALL vector_create_start(new_vector,err,error,*999)
5320  CALL vector_data_type_set(new_vector,vector%DATA_TYPE,err,error,*999)
5321  CALL vector_size_set(new_vector,vector%N,err,error,*999)
5322  CALL vector_create_finish(new_vector,err,error,*999)
5323  ENDIF
5324  ELSE
5325  CALL flagerror("Vector is not associated.",err,error,*998)
5326  ENDIF
5327 
5328  exits("VECTOR_DUPLICATE")
5329  RETURN
5330 999 CALL vector_finalise(new_vector,err,error,*998)
5331 998 errorsexits("VECTOR_DUPLICATE",err,error)
5332  RETURN 1
5333  END SUBROUTINE vector_duplicate
5334 
5335  !
5336  !================================================================================================================================
5337  !
5338 
5340  SUBROUTINE vector_finalise(VECTOR,ERR,ERROR,*)
5342  !Argument variables
5343  TYPE(vector_type), POINTER :: VECTOR
5344  INTEGER(INTG), INTENT(OUT) :: ERR
5345  TYPE(varying_string), INTENT(OUT) :: ERROR
5346  !Local Variables
5347 
5348  enters("VECTOR_FINALISE",err,error,*999)
5349 
5350  IF(ASSOCIATED(vector)) THEN
5351  IF(ALLOCATED(vector%DATA_INTG)) DEALLOCATE(vector%DATA_INTG)
5352  IF(ALLOCATED(vector%DATA_SP)) DEALLOCATE(vector%DATA_SP)
5353  IF(ALLOCATED(vector%DATA_DP)) DEALLOCATE(vector%DATA_DP)
5354  IF(ALLOCATED(vector%DATA_L)) DEALLOCATE(vector%DATA_L)
5355  DEALLOCATE(vector)
5356  ENDIF
5357 
5358  exits("VECTOR_FINALISE")
5359  RETURN
5360 999 errorsexits("VECTOR_FINALISE",err,error)
5361  RETURN 1
5362  END SUBROUTINE vector_finalise
5363 
5364  !
5365  !================================================================================================================================
5366  !
5367 
5369  SUBROUTINE vector_initialise(VECTOR,ERR,ERROR,*)
5371  !Argument variables
5372  TYPE(vector_type), POINTER :: VECTOR
5373  INTEGER(INTG), INTENT(OUT) :: ERR
5374  TYPE(varying_string), INTENT(OUT) :: ERROR
5375  !Local Variables
5376 
5377  enters("VECTOR_INITIALISE",err,error,*999)
5378 
5379  IF(ASSOCIATED(vector)) THEN
5380  !!TODO: have a vector user number etc.
5381  vector%ID=0
5382  vector%VECTOR_FINISHED=.false.
5383  vector%N=0
5384  vector%DATA_TYPE=0
5385  vector%SIZE=0
5386  ELSE
5387  CALL flagerror("Vector is not associated.",err,error,*999)
5388  ENDIF
5389 
5390  exits("VECTOR_INITIALISE")
5391  RETURN
5392 999 errorsexits("VECTOR_INITIALISE",err,error)
5393  RETURN 1
5394  END SUBROUTINE vector_initialise
5395 
5396  !
5397  !================================================================================================================================
5398  !
5399 
5401  SUBROUTINE vector_size_set(VECTOR,N,ERR,ERROR,*)
5403  !Argument variables
5404  TYPE(vector_type), POINTER :: VECTOR
5405  INTEGER(INTG), INTENT(IN) :: N
5406  INTEGER(INTG), INTENT(OUT) :: ERR
5407  TYPE(varying_string), INTENT(OUT) :: ERROR
5408  !Local Variables
5409  TYPE(varying_string) :: LOCAL_ERROR
5410 
5411  enters("VECTOR_SIZE_SET",err,error,*999)
5412 
5413  IF(ASSOCIATED(vector)) THEN
5414  IF(vector%VECTOR_FINISHED) THEN
5415  CALL flagerror("The vector has been finished.",err,error,*999)
5416  ELSE
5417  IF(n>0) THEN
5418  vector%N=n
5419  ELSE
5420  local_error="The size of the vector ("//trim(number_to_vstring(n,"*",err,error))// &
5421  & ") is invalid. The number must be >0."
5422  CALL flagerror(local_error,err,error,*999)
5423  ENDIF
5424  ENDIF
5425  ELSE
5426  CALL flagerror("Vector is not associated.",err,error,*999)
5427  ENDIF
5428 
5429  exits("VECTOR_SIZE_SET")
5430  RETURN
5431 999 errorsexits("VECTOR_SIZE_SET",err,error)
5432