00001
00003
00019 module mod_vector
00020 #include "fml_constants.h"
00021 use mod_exception
00022 use mod_utility
00023 use mod_maths
00024 implicit none
00025
00026
00027
00028
00029
00033
00034
00042 type vector
00043 integer :: size=1;
00044 type_precision, dimension(:), allocatable :: ptr_container(:)
00045 logical :: is_allocate = .false.
00046 end type vector
00047
00053 interface operator(*)
00054 module procedure v_prod_vec, v_prod_scalar1, v_prod_scalar2
00055 end interface
00056
00062 interface operator(/)
00063 module procedure v_div_scalar
00064 end interface
00065
00066
00072 interface operator(==)
00073 module procedure v_isEqual, v_isEqual_scalar
00074 end interface
00075
00081 interface operator(+)
00082 module procedure v_add
00083 end interface
00084
00090 interface operator(-)
00091 module procedure v_minus
00092 end interface
00093
00099 interface assignment(=)
00100 module procedure v_affect
00101 end interface
00102
00103
00109 interface operator(.len.)
00110 module procedure v_size
00111 end interface
00112
00118 interface operator(.norm.)
00119 module procedure v_length
00120 end interface
00121
00127 interface operator(.sqrnorm.)
00128 module procedure v_sqrLength
00129 end interface
00130
00131
00132
00138 interface operator(.cross.)
00139 module procedure v_cross
00140 end interface
00141
00142
00148 interface operator(.dot.)
00149 module procedure v_dot
00150 end interface
00151
00157 interface operator(.inv.)
00158 module procedure v_inverse
00159 end interface
00160
00166 interface destruct
00167 module procedure v_destruct
00168 end interface
00169
00175 interface add
00176 module procedure v_add_val_end
00177 end interface
00178
00179
00185 interface sum
00186 module procedure v_sum
00187 end interface
00188
00194 interface min
00195 module procedure v_min
00196 end interface
00197
00203 interface max
00204 module procedure v_max
00205 end interface
00206
00212 interface abs
00213 module procedure v_abs
00214 end interface
00215
00221 interface dot
00222 module procedure v_dot
00223 end interface
00224
00230 interface norm
00231 module procedure v_norm
00232 end interface
00233
00239 interface sqrnorm
00240 module procedure v_sqrLength
00241 end interface
00242
00248 interface get
00249 module procedure v_get, v_get_v
00250 end interface
00251
00257 interface set
00258 module procedure v_set
00259 end interface
00260
00266 interface random
00267 module procedure vc_random
00268 end interface
00269
00275 interface init
00276 module procedure v_init, v_init_fromfile
00277 end interface
00278
00284 interface print
00285 module procedure v_print, v_print_tofile
00286 end interface
00287
00288
00290 character(len=len_what_exception) :: v_what_exception
00291
00292
00294 integer, parameter :: infty = 0
00295 CONTAINS
00296
00297
00305 subroutine v_init(v,size_v)
00306 implicit none
00307 type(vector) :: v;
00308 integer, intent(in), optional :: size_v;
00309
00310 integer(kind=2) :: ierr;
00311 type(type_exception) :: err_exception;
00312 integer :: in_size_v=2;
00313
00314 if(present(size_v)) in_size_v=size_v;
00315 #ifdef DEBUG_EXCEPTION
00316 if (in_size_v .lt. 1) then
00317 v_what_exception='v_init::positive size expected'
00318 err_exception=e_error(stop_array_indice_exceed,v_what_exception,stop_array_indice_exceed)
00319 endif
00320 #endif
00321 call destruct(v)
00322
00323 v%size=in_size_v
00324 allocate(v%ptr_container(v%size),stat=ierr)
00325 #ifdef DEBUG_EXCEPTION
00326 if (ierr .ne. 0) then
00327 v_what_exception='v_init::vector allocate error'
00328 err_exception=e_error(stop_aloc,v_what_exception,stop_aloc)
00329 endif
00330 #endif
00331 v%ptr_container(:)=0
00332 v%is_allocate = allocated(v%ptr_container)
00333 end subroutine v_init
00334
00335
00343 subroutine v_init_fromfile(v,filename,unit)
00344 implicit none
00345 type(vector) :: v;
00346 character*(*), intent(in) :: filename
00347 integer, intent(in), optional :: unit
00348
00349 integer(kind=2) :: ierr;
00350 type(type_exception) :: err_exception;
00351 integer :: in_unit
00352 integer :: i
00353
00354 if(u_is_exist_file(filename)) then
00355 call destruct(v)
00356
00357 if(present(unit)) then
00358 in_unit=unit;
00359 else
00360 in_unit=22
00361 end if
00362
00363
00364 open (unit=in_unit,file=filename, form="formatted", action="read",status="unknown")
00365 read (unit=in_unit,fmt=*,end=1000)v%size
00366 #ifdef DEBUG_EXCEPTION
00367 if (v%size .lt. 1) then
00368 v_what_exception='v_init_fromfile::positive size expected'
00369 err_exception=e_error(stop_array_indice_exceed,v_what_exception,stop_array_indice_exceed)
00370 endif
00371 #endif
00372 allocate(v%ptr_container(v%size),stat=ierr)
00373 #ifdef DEBUG_EXCEPTION
00374 if (ierr .ne. 0) then
00375 v_what_exception='v_init_fromfile::vector allocate error'
00376 err_exception=e_error(stop_aloc,v_what_exception,stop_aloc)
00377 endif
00378 #endif
00379 read (unit=in_unit,fmt=*,end=1000) v%ptr_container
00380 1000 close(unit=in_unit)
00381 v%is_allocate = allocated(v%ptr_container)
00382 end if
00383 end subroutine v_init_fromfile
00384
00385
00386
00393 subroutine v_resize(v,size_v)
00394 implicit none
00395 type(vector),intent(inout) :: v;
00396 integer, intent(in) :: size_v;
00397
00398 integer(kind=2) :: ierr;
00399 type(type_exception) :: err_exception;
00400 #ifdef DEBUG_EXCEPTION
00401 if (size_v .lt. 1) then
00402 v_what_exception='v_resize::positive size expected'
00403 err_exception=e_error(stop_array_indice_exceed,v_what_exception,stop_array_indice_exceed)
00404 endif
00405 #endif
00406 call destruct(v)
00407
00408 v%size=size_v
00409 allocate(v%ptr_container(v%size),stat=ierr)
00410 #ifdef DEBUG_EXCEPTION
00411 if (ierr .ne. 0) then
00412 v_what_exception='v_resize::vector allocate error'
00413 err_exception=e_error(stop_aloc,v_what_exception,stop_aloc)
00414 endif
00415 #endif
00416 v%ptr_container(:)=0
00417 v%is_allocate = allocated(v%ptr_container)
00418 end subroutine v_resize
00419
00420
00426 subroutine v_destruct(v)
00427 implicit none
00428 type(vector) :: v;
00429
00430 integer(kind=2) :: ierr;
00431 type(type_exception) :: err_exception;
00432
00433 if(v%is_allocate) then
00434 deallocate(v%ptr_container,stat=ierr)
00435 #ifdef DEBUG_EXCEPTION
00436 if (ierr .ne. 0) then
00437 v_what_exception='v_destruct::vector deallocate error'
00438 err_exception=e_error(stop_dealoc,v_what_exception,stop_dealoc)
00439 endif
00440 #endif
00441 v%is_allocate = allocated(v%ptr_container)
00442 end if
00443 end subroutine v_destruct
00444
00445
00453 subroutine vc_random(v,low,high)
00454 implicit none
00455 type(vector), intent(inout) :: v;
00456 type_precision, intent(in), optional :: low
00457 type_precision, intent(in), optional :: high
00458
00459 type_precision :: in_low, in_high
00460 type(type_exception) :: err_exception;
00461 integer :: i
00462 real :: x
00463 #ifdef DEBUG_EXCEPTION
00464 if (.not. v%is_allocate) then
00465 v_what_exception='vc_random::vector not allocate yet'
00466 err_exception=e_error(stop_aloc,v_what_exception,stop_aloc)
00467 endif
00468 #endif
00469 if(present(low)) then
00470 in_low=low;
00471 else
00472 in_low=1.0;
00473 end if
00474 if(present(high)) then
00475 in_high=high;
00476 else
00477 in_high=v%size;
00478 end if
00479
00480
00481
00482
00483 do i=1,v%size
00484 v%ptr_container(i)=rand(i**100*int(secnds(x)))*(in_high-in_low)+in_low
00485 end do
00486 end subroutine vc_random
00487
00488
00495 function v_ones(size_v) result(res)
00496 implicit none
00497 integer, intent(in) :: size_v;
00498
00499 type(vector) ::res;
00500 type(type_exception) :: err_exception;
00501 integer(kind=2) :: ierr;
00502 integer :: i
00503 #ifdef DEBUG_EXCEPTION
00504 if (size_v.lt.1) then
00505 v_what_exception='v_ones::vector size is nil or negative'
00506 err_exception=e_error(stop_array_indice_exceed,v_what_exception,stop_array_indice_exceed)
00507 endif
00508 #endif
00509 res%size=size_v
00510 allocate(res%ptr_container(res%size),stat=ierr)
00511 #ifdef DEBUG_EXCEPTION
00512 if (ierr .ne. 0) then
00513 v_what_exception='v_ones::allocate error'
00514 err_exception=e_error(stop_aloc,v_what_exception,stop_aloc)
00515 endif
00516 #endif
00517 res%ptr_container=1
00518 res%is_allocate = allocated(res%ptr_container)
00519 end function v_ones
00520
00521
00528 subroutine v_init_value(v,value)
00529 implicit none
00530 type_precision,intent(in) :: value
00531 type(vector) :: v;
00532
00533 type(type_exception) :: err_exception;
00534 #ifdef DEBUG_EXCEPTION
00535 if (.not. v%is_allocate) then
00536 v_what_exception='v_ones::vector not allocate yet'
00537 err_exception=e_error(stop_aloc,v_what_exception,stop_aloc)
00538 endif
00539 #endif
00540 v%ptr_container=value
00541 end subroutine v_init_value
00542
00543
00550 function v_zeros(size_v) result(res)
00551 implicit none
00552 integer, intent(in) :: size_v;
00553
00554 type(vector) ::res;
00555 type(type_exception) :: err_exception;
00556 integer(kind=2) :: ierr;
00557
00558 res%size=size_v
00559 allocate(res%ptr_container(res%size),stat=ierr)
00560 #ifdef DEBUG_EXCEPTION
00561 if (ierr .ne. 0) then
00562 v_what_exception='v_zeros::vector allocate error'
00563 err_exception=e_error(stop_aloc,v_what_exception,stop_aloc)
00564 endif
00565 #endif
00566 res%ptr_container(:)=0
00567 res%is_allocate = allocated(res%ptr_container)
00568 end function v_zeros
00569
00570
00577 subroutine v_add_val_end(v,val)
00578 implicit none
00579 type(vector),intent(inout) :: v;
00580 type_precision, intent(in) :: val;
00581
00582 integer(kind=2) :: ierr;
00583 type(type_exception) :: err_exception;
00584 type_precision :: array_tmp(v%size)
00585 #ifdef DEBUG_EXCEPTION
00586 if(.not.(v%is_allocate)) then
00587 v_what_exception='v_add::vector not allocated'
00588 err_exception=e_error(stop_aloc,v_what_exception,stop_aloc)
00589 endif
00590 #endif
00591 array_tmp=v%ptr_container
00592 call destruct(v)
00593 v%size=v%size+1
00594 allocate(v%ptr_container(v%size),stat=ierr)
00595 #ifdef DEBUG_EXCEPTION
00596 if (ierr .ne. 0) then
00597 v_what_exception='v_add::vector allocate error'
00598 err_exception=e_error(stop_aloc,v_what_exception,stop_aloc)
00599 endif
00600 #endif
00601 v%ptr_container(1:size(array_tmp))=array_tmp
00602 v%ptr_container(v%size)=val
00603 v%is_allocate = allocated(v%ptr_container)
00604 end subroutine v_add_val_end
00605
00606
00618 function v_extract(v,l_bound,u_bound) result (res)
00619 type(vector), intent(in) :: v
00620 integer, intent(in), optional :: l_bound, u_bound
00621
00622 type(type_exception) :: err_exception;
00623 type(vector) :: res
00624 integer :: in_l_bound=1, in_u_bound=1
00625
00626 if(present(l_bound)) in_l_bound=l_bound;
00627 if(present(u_bound)) in_u_bound=u_bound;
00628 call v_init(res,in_u_bound-in_l_bound+1);
00629 res%ptr_container=v%ptr_container(in_l_bound:in_u_bound)
00630 end function v_extract
00631
00632
00640 function v_get(v,i) result (res)
00641 type(vector), intent(in) :: v
00642 integer, intent(in) :: i
00643
00644 type(type_exception) :: err_exception;
00645 type_precision :: res
00646 #ifdef DEBUG_EXCEPTION
00647 if(.not.(v%is_allocate)) then
00648 v_what_exception='v_get::vector not allocated'
00649 err_exception=e_error(stop_aloc,v_what_exception,stop_aloc)
00650 endif
00651 if ((i .lt. 1) .or. (i .GT. v%size)) then
00652 v_what_exception='v_get::vector size nil or negative'
00653 err_exception=e_error(stop_array_indice_exceed,v_what_exception,stop_array_indice_exceed)
00654 endif
00655 #endif
00656 res=v%ptr_container(i)
00657 end function v_get
00658
00659
00666 function v_get_v(v) result (res)
00667 type(vector), intent(in) :: v
00668
00669 type(type_exception) :: err_exception;
00670 type_precision :: res(v%size)
00671 #ifdef DEBUG_EXCEPTION
00672 if(.not.(v%is_allocate)) then
00673 v_what_exception='v_get_v::vector not allocated'
00674 err_exception=e_error(stop_aloc,v_what_exception,stop_aloc)
00675 endif
00676 #endif
00677 res=v%ptr_container
00678 end function v_get_v
00679
00680
00688 subroutine v_set(v,i,value)
00689 type(vector), intent(inout) :: v
00690 integer, intent(in) :: i
00691 type_precision, intent(in) :: value
00692
00693 type(type_exception) :: err_exception;
00694 #ifdef DEBUG_EXCEPTION
00695 if(.not.(v%is_allocate)) then
00696 v_what_exception='v_set::vector not allocated'
00697 err_exception=e_error(stop_aloc,v_what_exception,stop_aloc)
00698 endif
00699 if ((i .lt. 1) .or. (i .GT. v%size)) then
00700 v_what_exception='v_set::vector size nil or negative'
00701 err_exception=e_error(stop_array_indice_exceed,v_what_exception,stop_array_indice_exceed)
00702 endif
00703 #endif
00704 v%ptr_container(i)=value
00705 end subroutine v_set
00706
00707
00714 subroutine v_affect(v,value)
00715 type(vector), intent(inout) :: v
00716 type_precision, intent(in) :: value
00717
00718 type(type_exception) :: err_exception;
00719 #ifdef DEBUG_EXCEPTION
00720 if(.not.(v%is_allocate)) then
00721 v_what_exception='v_set::vector not allocated'
00722 err_exception=e_error(stop_aloc,v_what_exception,stop_aloc)
00723 endif
00724 #endif
00725 v%ptr_container(:)=value
00726 end subroutine v_affect
00727
00728
00729
00730
00731
00732
00739 function v_size(v) result (nb)
00740 type(vector), intent(in) :: v
00741
00742 integer :: nb
00743 type(type_exception) :: err_exception;
00744 #ifdef DEBUG_EXCEPTION
00745 if(.not.(v%is_allocate)) then
00746 v_what_exception='v_size::vector not allocated'
00747 err_exception=e_error(stop_aloc,v_what_exception,stop_aloc)
00748 endif
00749 #endif
00750 nb=v%size
00751 end function v_size
00752
00753
00760 function v_nbnegative(v) result (nb)
00761 type(vector), intent(in) :: v
00762
00763 integer :: nb
00764 type(type_exception) :: err_exception;
00765 #ifdef DEBUG_EXCEPTION
00766 if(.not.(v%is_allocate)) then
00767 v_what_exception='v_nbnegative::vector not allocated'
00768 err_exception=e_error(stop_aloc,v_what_exception,stop_aloc)
00769 endif
00770 #endif
00771 nb = count(v%ptr_container<0);
00772 end function v_nbnegative
00773
00774
00781 function v_nbpositive(v) result (nb)
00782 type(vector), intent(in) :: v
00783
00784 integer :: nb
00785 type(type_exception) :: err_exception;
00786 #ifdef DEBUG_EXCEPTION
00787 if(.not.(v%is_allocate)) then
00788 v_what_exception='v_nbpositive::vector not allocated'
00789 err_exception=e_error(stop_aloc,v_what_exception,stop_aloc)
00790 endif
00791 #endif
00792 nb = count(v%ptr_container>0);
00793 end function v_nbpositive
00794
00795
00802 function v_nbzeros(v) result (nb)
00803 type(vector), intent(in) :: v
00804
00805 integer :: nb
00806 type(type_exception) :: err_exception;
00807 #ifdef DEBUG_EXCEPTION
00808 if(.not.(v%is_allocate)) then
00809 v_what_exception='v_nbzeros::vector not allocated'
00810 err_exception=e_error(stop_aloc,v_what_exception,stop_aloc)
00811 endif
00812 #endif
00813 nb = count(v%ptr_container==0);
00814 end function v_nbzeros
00815
00816
00823 function v_max(v) result (val)
00824 type(vector), intent(in) :: v
00825
00826 type_precision :: val
00827 type(type_exception) :: err_exception;
00828 #ifdef DEBUG_EXCEPTION
00829 if(.not.(v%is_allocate)) then
00830 v_what_exception='v_max::vector not allocated'
00831 err_exception=e_error(stop_aloc,v_what_exception,stop_aloc)
00832 endif
00833 #endif
00834 val= maxval(v%ptr_container);
00835 end function v_max
00836
00837
00844 function v_min(v) result (val)
00845 type(vector), intent(in) :: v
00846
00847 type_precision :: val
00848 type(type_exception) :: err_exception;
00849 #ifdef DEBUG_EXCEPTION
00850 if(.not.(v%is_allocate)) then
00851 v_what_exception='v_min::vector not allocated'
00852 err_exception=e_error(stop_aloc,v_what_exception,stop_aloc)
00853 endif
00854 #endif
00855 val= minval(v%ptr_container);
00856 end function v_min
00857
00858
00865 function v_abs(v) result (res)
00866 type(vector), intent(in) :: v
00867
00868 type_precision :: res
00869 integer :: i
00870 type(type_exception) :: err_exception;
00871 #ifdef DEBUG_EXCEPTION
00872 if(.not.(v%is_allocate)) then
00873 v_what_exception='v_abs::vector not allocated'
00874 err_exception=e_error(stop_aloc,v_what_exception,stop_aloc)
00875 endif
00876 #endif
00877 do i=1,v%size
00878 res=abs(v%ptr_container(i));
00879 end do
00880 end function v_abs
00881
00882
00889 function v_sum(v) result (val)
00890 type(vector), intent(in) :: v
00891
00892 type_precision :: val
00893 type(type_exception) :: err_exception;
00894 val=0
00895 #ifdef DEBUG_EXCEPTION
00896 if(.not.(v%is_allocate)) then
00897 v_what_exception='v_sum::vector not allocated'
00898 err_exception=e_error(stop_aloc,v_what_exception,stop_aloc)
00899 endif
00900 #endif
00901 val= sum(v%ptr_container);
00902 end function v_sum
00903
00904
00911 function v_prod(v) result (val)
00912 type(vector), intent(in) :: v
00913
00914 type_precision :: val
00915 type(type_exception) :: err_exception;
00916 integer :: i
00917 val=1
00918 #ifdef DEBUG_EXCEPTION
00919 if(.not.(v%is_allocate)) then
00920 v_what_exception='v_prod::vector not allocated'
00921 err_exception=e_error(stop_aloc,v_what_exception,stop_aloc)
00922 endif
00923 #endif
00924 do i=1,v%size
00925 val = val * v%ptr_container(i)
00926 end do
00927 end function v_prod
00928
00929
00930
00931
00932
00933
00940 function v_inverse(v) result (res)
00941 type(vector), intent(in) :: v
00942
00943 type(type_exception) :: err_exception;
00944 type(vector) :: res
00945 #ifdef DEBUG_EXCEPTION
00946 if(.not.(v%is_allocate)) then
00947 v_what_exception='v_inverse::vector not allocated'
00948 err_exception=e_error(stop_aloc,v_what_exception,stop_aloc)
00949 endif
00950 if(v_nbzeros(v).ne.0) then
00951 v_what_exception='v_inverse::one of vector element is null'
00952 err_exception=e_error(stop_aloc,v_what_exception,stop_aloc)
00953 endif
00954 #endif
00955 call v_init(res,v%size)
00956 res%ptr_container=1/v%ptr_container
00957 end function v_inverse
00958
00959
00960
00961
00962
00963
00971 function v_prod_vec (v1,v2) result (res)
00972 implicit none
00973 type(vector),intent(in) :: v1,v2
00974 type(vector) :: res
00975
00976 type(type_exception) :: err_exception;
00977 #ifdef DEBUG_EXCEPTION
00978 if(.not.(v1%is_allocate) .or. .not.(v2%is_allocate)) then
00979 v_what_exception='v_prod_vec::vector not allocated'
00980 err_exception=e_error(stop_aloc,v_what_exception,stop_aloc)
00981 endif
00982 if (v1%size.ne.v2%size) then
00983 v_what_exception='v_prod_vec::vector must have the same size'
00984 err_exception=e_error(stop_array_compatible,v_what_exception,stop_array_compatible)
00985 endif
00986 #endif
00987 call v_init(res,v1%size)
00988
00989 res%ptr_container = v1%ptr_container*v2%ptr_container
00990 end function v_prod_vec
00991
00992
01000 function v_prod_scalar1 (v,alpha) result (res)
01001 implicit none
01002 type(vector),intent(in) :: v
01003 type_precision,intent(in) :: alpha
01004 type(vector) :: res
01005
01006 type(type_exception) :: err_exception;
01007 #ifdef DEBUG_EXCEPTION
01008 if(.not.(v%is_allocate)) then
01009 v_what_exception='v_prod_scalar1::vector not allocated'
01010 err_exception=e_error(stop_aloc,v_what_exception,stop_aloc)
01011 endif
01012 #endif
01013 call v_init(res,v%size)
01014 res%ptr_container = v%ptr_container*alpha
01015 end function v_prod_scalar1
01016
01017
01025 function v_prod_scalar2 (alpha,v) result (res)
01026 implicit none
01027 type(vector),intent(in) :: v
01028 type_precision,intent(in) :: alpha
01029 type(vector) :: res
01030
01031 type(type_exception) :: err_exception;
01032 #ifdef DEBUG_EXCEPTION
01033 if(.not.(v%is_allocate)) then
01034 v_what_exception='v_prod_scalar2::vector not allocated'
01035 err_exception=e_error(stop_aloc,v_what_exception,stop_aloc)
01036 endif
01037 #endif
01038 call v_init(res,v%size)
01039 res%ptr_container = alpha*v%ptr_container
01040 end function v_prod_scalar2
01041
01042
01050 function v_div_scalar(v,alpha) result (res)
01051 implicit none
01052 type(vector),intent(in) :: v
01053 type_precision,intent(in) :: alpha
01054 type(vector) :: res
01055
01056 type(type_exception) :: err_exception;
01057 #ifdef DEBUG_EXCEPTION
01058 if(.not.(v%is_allocate)) then
01059 v_what_exception='v_div_scalar::vector not allocated'
01060 err_exception=e_error(stop_aloc,v_what_exception,stop_aloc)
01061 endif
01062 if(alpha.eq.0) then
01063 v_what_exception='v_div_scalar::can not divide by zero'
01064 err_exception=e_error(stop_div0,v_what_exception,stop_div0)
01065 end if
01066 #endif
01067 call v_init(res,v%size)
01068 res%ptr_container = v%ptr_container/alpha
01069 end function v_div_scalar
01070
01071
01072
01073
01074
01075
01076
01084 function v_add(v1,v2) result (res)
01085 implicit none
01086 type(vector),intent(in) :: v1,v2
01087
01088 type(vector) :: res
01089 type(type_exception) :: err_exception;
01090 #ifdef DEBUG_EXCEPTION
01091 if(.not.(v1%is_allocate) .or. .not.(v2%is_allocate)) then
01092 v_what_exception='v_add::vector not allocated'
01093 err_exception=e_error(stop_aloc,v_what_exception,stop_aloc)
01094 endif
01095 if (v1%size .ne. v2%size) then
01096 v_what_exception='v_add::vectors are not the same size'
01097 err_exception=e_error(stop_array_compatible,v_what_exception,stop_array_compatible)
01098 endif
01099 #endif
01100 call v_init(res,v1%size)
01101 res%ptr_container=v1%ptr_container+v2%ptr_container
01102 end function v_add
01103
01104
01105
01106
01107
01108
01116 function v_minus(v1,v2) result (res)
01117 implicit none
01118 type(vector),intent(in) :: v1,v2
01119
01120 type(vector) :: res
01121 type(type_exception) :: err_exception;
01122 #ifdef DEBUG_EXCEPTION
01123 if(.not.(v1%is_allocate) .or. .not.(v2%is_allocate)) then
01124 v_what_exception='v_minus::vector not allocated'
01125 err_exception=e_error(stop_aloc,v_what_exception,stop_aloc)
01126 endif
01127 if (v1%size .ne. v2%size) then
01128 v_what_exception='v_minus::vectors are not the same size'
01129 err_exception=e_error(stop_array_compatible,v_what_exception,stop_array_compatible)
01130 endif
01131 #endif
01132 call v_init(res,v1%size)
01133 res%ptr_container=v1%ptr_container-v2%ptr_container
01134 end function v_minus
01135
01136
01137
01138
01139
01140
01150 function v_axpby(alpha,x,beta,y) result (res)
01151 implicit none
01152 type_precision,intent(in) :: alpha
01153 type(vector),intent(in) :: x
01154 type_precision,intent(in), optional :: beta
01155 type(vector),intent(in), optional :: y
01156
01157 type_precision :: in_beta
01158 type(vector) :: res
01159 type(type_exception) :: err_exception;
01160 #ifdef DEBUG_EXCEPTION
01161 if(.not.(x%is_allocate)) then
01162 v_what_exception='v_axpby::vector not allocated'
01163 err_exception=e_error(stop_aloc,v_what_exception,stop_aloc)
01164 endif
01165 #endif
01166 if(present(beta)) then
01167 in_beta=beta;
01168 else
01169 in_beta=1.0;
01170 end if
01171
01172 if(present(y) .and. present(beta)) then
01173 #ifdef DEBUG_EXCEPTION
01174 if(.not.(y%is_allocate)) then
01175 v_what_exception='v_axpby::vector not allocated'
01176 err_exception=e_error(stop_aloc,v_what_exception,stop_aloc)
01177 endif
01178 #endif
01179 if (x%size.ne.y%size) then
01180 v_what_exception='v_axpby::vector must have the same size'
01181 err_exception=e_error(stop_array_compatible,v_what_exception,stop_array_compatible)
01182 endif
01183 res=alpha*x + in_beta*y
01184 else
01185 res=alpha*x
01186 end if
01187 end function v_axpby
01188
01189
01190
01191
01192
01193
01199 subroutine v_normalize(v)
01200 type(vector), intent(inout) :: v
01201
01202 type(type_exception) :: err_exception;
01203 #ifdef DEBUG_EXCEPTION
01204 if(.not.(v%is_allocate)) then
01205 v_what_exception='v_normalize::vector not allocated'
01206 err_exception=e_error(stop_aloc,v_what_exception,stop_aloc)
01207 endif
01208 #endif
01209 v%ptr_container = v%ptr_container/.norm.v
01210 end subroutine v_normalize
01211
01212
01219 function v_sqrLength(v) result (res)
01220 type(vector), intent(in) :: v
01221
01222 type(type_exception) :: err_exception;
01223 type_precision :: sum_tmp
01224 integer :: i
01225 type_precision :: res
01226 #ifdef DEBUG_EXCEPTION
01227 if(.not.(v%is_allocate)) then
01228 v_what_exception='v_sqrLength::vector not allocated'
01229 err_exception=e_error(stop_aloc,v_what_exception,stop_aloc)
01230 endif
01231 #endif
01232 res=0
01233
01234 do i=1,v%size
01235 res = res + v%ptr_container(i)**2
01236 end do
01237
01238 end function v_sqrLength
01239
01240
01241
01248 function v_length(v) result (res)
01249 type(vector), intent(in) :: v
01250
01251 type(type_exception) :: err_exception;
01252 integer :: i
01253 type_precision :: res
01254 #ifdef DEBUG_EXCEPTION
01255 if(.not.(v%is_allocate)) then
01256 v_what_exception='v_length::vector not allocated'
01257 err_exception=e_error(stop_aloc,v_what_exception,stop_aloc)
01258 endif
01259 #endif
01260 res=0
01261
01262 do i=1,v%size
01263 res = res + v%ptr_container(i)**2
01264 end do
01265
01266 res=sqrt(real(res))
01267 end function v_length
01268
01269
01277 function v_norm(v,type_norm) result (res)
01278 type(vector), intent(in) :: v
01279 integer, intent(in), optional :: type_norm
01280
01281 type(type_exception) :: err_exception;
01282 integer :: i
01283 integer :: in_type_norm
01284 type_precision :: res
01285 #ifdef DEBUG_EXCEPTION
01286 if(.not.(v%is_allocate)) then
01287 v_what_exception='v_norm::vector not allocated'
01288 err_exception=e_error(stop_aloc,v_what_exception,stop_aloc)
01289 endif
01290 #endif
01291 if(present(type_norm)) then
01292 in_type_norm=type_norm
01293 else
01294 in_type_norm=2
01295 end if
01296
01297 res=0
01298 if(in_type_norm.eq.infty) then
01299 res=maxval(abs(v%ptr_container))
01300 else
01301
01302 do i=1,v%size
01303 res = res + abs(v%ptr_container(i))**in_type_norm
01304 end do
01305
01306 res=res**(1.0/in_type_norm)
01307 end if
01308 end function v_norm
01309
01310
01311
01320 function v_dot(v1,v2) result (res)
01321 type(vector), intent(in) :: v1, v2
01322
01323 type(type_exception) :: err_exception;
01324 type_precision :: res
01325 integer :: i
01326 #ifdef DEBUG_EXCEPTION
01327 if(.not.(v1%is_allocate) .or. .not.(v2%is_allocate)) then
01328 v_what_exception='v_dot::vector not allocated'
01329 err_exception=e_error(stop_aloc,v_what_exception,stop_aloc)
01330 endif
01331 #endif
01332 res=0
01333
01334 do i=1,v1%size
01335 res = res + v1%ptr_container(i)*v2%ptr_container(i)
01336 end do
01337
01338
01339 end function v_dot
01340
01341
01349 function v_cross(v1,v2) result (res)
01350 type(vector), intent(in) :: v1, v2
01351
01352 type(type_exception) :: err_exception;
01353 type(vector) :: res
01354 #ifdef DEBUG_EXCEPTION
01355 if(.not.(v1%is_allocate) .or. .not.(v2%is_allocate)) then
01356 v_what_exception='v_cross::vector not allocated'
01357 err_exception=e_error(stop_aloc,v_what_exception,stop_aloc)
01358 endif
01359 if( (v1%size .ne. v2%size).or. (v1%size.ne.3) ) then
01360 v_what_exception='v_cross::vectors have not the same size or are not 3-dimensional vectors'
01361 err_exception=e_error(stop_array_compatible,v_what_exception,stop_array_compatible)
01362 endif
01363 #endif
01364 res%ptr_container(1)=v1%ptr_container(2)*v1%ptr_container(3) - v1%ptr_container(3)*v1%ptr_container(2)
01365 res%ptr_container(2)=v1%ptr_container(3)*v1%ptr_container(1) - v1%ptr_container(1)*v1%ptr_container(3)
01366 res%ptr_container(3)=v1%ptr_container(1)*v1%ptr_container(2) - v1%ptr_container(2)*v1%ptr_container(1)
01367
01368 end function v_cross
01369
01370
01378 function v_isEqual(v1,v2) result (res)
01379
01380 type(vector), intent(in) :: v1, v2
01381
01382 type(type_exception) :: err_exception;
01383 logical :: res
01384
01385 res = .false.
01386 #ifdef DEBUG_EXCEPTION
01387 if(.not.(v1%is_allocate) .or. .not.(v2%is_allocate)) then
01388 v_what_exception='v_isEqual::vector not allocated'
01389 err_exception=e_error(stop_aloc,v_what_exception,stop_aloc)
01390 endif
01391 if (v1%size .ne. v2%size) then
01392 v_what_exception='v_isEqual::vectors are not the same size'
01393 err_exception=e_error(stop_array_compatible,v_what_exception,stop_array_compatible)
01394 endif
01395 #endif
01396 if( count(v1%ptr_container.ne.v2%ptr_container)==0) res = .true.
01397 end function v_isEqual
01398
01399
01407 function v_isEqual_scalar(v,val) result (res)
01408
01409 type(vector), intent(in) :: v
01410 type_precision, intent(in) :: val
01411
01412 type(type_exception) :: err_exception;
01413 logical :: res
01414 res = .false.
01415 #ifdef DEBUG_EXCEPTION
01416 if(.not.(v%is_allocate)) then
01417 v_what_exception='v_isEqual_scalar::vector not allocated'
01418 err_exception=e_error(stop_aloc,v_what_exception,stop_aloc)
01419 endif
01420 #endif
01421 if( count(v%ptr_container.ne.val)==0) res = .true.
01422 end function v_isEqual_scalar
01423
01424
01425
01426
01427
01428
01429
01430
01431
01432
01433
01440 subroutine v_print(v)
01441 implicit none
01442 type(vector), intent(in) :: v
01443
01444 type(type_exception) :: err_exception;
01445 #ifdef DEBUG_EXCEPTION
01446 if(.not.(v%is_allocate)) then
01447 v_what_exception='v_print::vector not allocated'
01448 err_exception=e_error(stop_aloc,v_what_exception,stop_aloc)
01449 endif
01450 #endif
01451 print*, v%ptr_container
01452 end subroutine v_print
01453
01454
01465 subroutine v_print_tofile(v,filename,unit,status,position)
01466 implicit none
01467 type(vector), intent(in) :: v
01468 character*(*), intent(in) :: filename
01469 integer, intent(in), optional :: unit
01470 character*(*), intent(in), optional :: status
01471 character*(*), intent(in), optional :: position
01472
01473 type(type_exception) :: err_exception;
01474 integer :: in_unit
01475 character*10 :: in_status
01476 character*10 :: in_position
01477 integer :: i
01478 #ifdef DEBUG_EXCEPTION
01479 if(.not.(v%is_allocate)) then
01480 v_what_exception='v_print_tofile::vector not allocated'
01481 err_exception=e_error(stop_aloc,v_what_exception,stop_aloc)
01482 endif
01483 #endif
01484
01485 if(present(unit)) then
01486 in_unit=unit;
01487 else
01488 in_unit=11
01489 end if
01490 if(present(status)) then
01491 in_status=status;
01492 else
01493 in_status='unknown'
01494 end if
01495 if(present(position)) then
01496 in_position=position;
01497 else
01498 in_position='rewind'
01499 end if
01500
01501 open (unit=in_unit,file=filename, form="formatted", action="write",status=in_status,position=in_position)
01502 write(in_unit,fmt='(i0)') v%size
01503 do i=1,v%size-1
01504 write(in_unit,fmt=p_fmt_file,advance='no') v%ptr_container(i)
01505 write(in_unit,fmt='(a1)',advance='no') " "
01506 end do
01507 write(in_unit,fmt=p_fmt_file) v%ptr_container(v%size)
01508 close(unit=in_unit)
01509
01510 end subroutine v_print_tofile
01511
01512
01513
01520 subroutine v_print_c(v)
01521 implicit none
01522 type(vector), intent(in) :: v
01523
01524 type(type_exception) :: err_exception;
01525 integer :: i
01526 #ifdef DEBUG_EXCEPTION
01527 if(.not.(v%is_allocate)) then
01528 v_what_exception='v_print_c::vector not allocated'
01529 err_exception=e_error(stop_aloc,v_what_exception,stop_aloc)
01530 endif
01531 #endif
01532 do i=1,v%size
01533 print*, v%ptr_container(i)
01534 end do
01535 end subroutine v_print_c
01536
01537
01548 subroutine v_print_c_tofile(v,filename,unit,status,position)
01549 implicit none
01550 type(vector), intent(in) :: v
01551 character*(*), intent(in) :: filename
01552 integer, intent(in), optional :: unit
01553 character*(*), intent(in), optional :: status
01554 character*(*), intent(in), optional :: position
01555
01556 type(type_exception) :: err_exception;
01557 integer :: in_unit
01558 character*10 :: in_status
01559 character*10 :: in_position
01560 #ifdef DEBUG_EXCEPTION
01561 if(.not.(v%is_allocate)) then
01562 v_what_exception='v_print_c_tofile::vector not allocated'
01563 err_exception=e_error(stop_aloc,v_what_exception,stop_aloc)
01564 endif
01565 #endif
01566
01567 if(present(unit)) then
01568 in_unit=unit;
01569 else
01570 in_unit=11
01571 end if
01572 if(present(status)) then
01573 in_status=status;
01574 else
01575 in_status='unknown'
01576 end if
01577 if(present(position)) then
01578 in_position=position;
01579 else
01580 in_position='rewind'
01581 end if
01582
01583 open (unit=in_unit,file=filename, form="formatted", action="write",status=in_status,position=in_position)
01584 write(in_unit,fmt='(i0)') v%size
01585 write(in_unit,fmt=p_fmt_file) v%ptr_container
01586 close(unit=in_unit)
01587
01588 end subroutine v_print_c_tofile
01589
01590 end module mod_vector
01591
01592
01593
01597
01601
01605