vector.f90

Go to the documentation of this file.
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   !*                      Type and interface definitions                        *!    
00028   !******************************************************************************!
00029   
00033 
00034   !**** brief type vector
00042   type vector
00043      integer :: size=1; ! (by defaul =1), vector size
00044      type_precision, dimension(:), allocatable :: ptr_container(:) ! vector container 
00045      logical :: is_allocate = .false. ! boolean, verify if the vector is allocate 
00046   end type vector
00047 
00053   interface operator(*) ! surcharge of
00054      module procedure v_prod_vec, v_prod_scalar1, v_prod_scalar2 ! operator *
00055   end interface
00056 
00062   interface operator(/) ! surcharge of
00063      module procedure v_div_scalar ! operator /
00064   end interface
00065   
00066 
00072   interface operator(==) ! surcharge of
00073      module procedure v_isEqual, v_isEqual_scalar ! operator ==
00074   end interface
00075 
00081   interface operator(+)    ! surcharge of
00082      module procedure v_add ! operator +
00083   end interface
00084 
00090   interface operator(-)      ! surcharge of
00091      module procedure v_minus ! operator -
00092   end interface
00093 
00099   interface assignment(=)        ! surcharge of
00100      module procedure v_affect  ! l'affectation (=)
00101   end interface
00102 
00103 
00109   interface operator(.len.)   ! Définition
00110      module procedure v_size ! de operator .len.
00111   end interface
00112 
00118   interface operator(.norm.)   ! Définition
00119      module procedure v_length ! de operator .norm.
00120   end interface
00121 
00127   interface operator(.sqrnorm.)   ! Définition
00128      module procedure v_sqrLength ! de operator .sqrnorm.
00129   end interface
00130   
00131 
00132 
00138   interface operator(.cross.)   ! Définition
00139      module procedure v_cross ! de operator .cross.
00140   end interface
00141 
00142 
00148   interface operator(.dot.)   ! Définition
00149      module procedure v_dot ! de operator .dot.
00150   end interface
00151 
00157   interface operator(.inv.)   ! Définition
00158      module procedure v_inverse  ! de operator .inv.
00159   end interface
00160  
00166   interface destruct   ! Définition
00167      module procedure v_destruct
00168   end interface
00169 
00175   interface add   ! Définition
00176      module procedure v_add_val_end
00177   end interface  
00178    
00179    
00185   interface sum   ! Définition
00186      module procedure v_sum 
00187   end interface
00188 
00194   interface min   ! definition
00195      module procedure v_min
00196   end interface
00197   
00203   interface max   ! definition
00204      module procedure v_max
00205   end interface
00206   
00212   interface abs   ! Définition
00213      module procedure v_abs 
00214   end interface
00215   
00221   interface dot   ! definition
00222      module procedure v_dot
00223   end interface
00224   
00230   interface norm   ! Définition
00231      module procedure v_norm
00232   end interface
00233 
00239   interface sqrnorm   ! Définition
00240      module procedure v_sqrLength
00241   end interface  
00242   
00248   interface get   ! Définition
00249      module procedure v_get, v_get_v 
00250   end interface
00251 
00257   interface set   ! Définition
00258      module procedure v_set 
00259   end interface
00260 
00266   interface random   ! Définition
00267      module procedure vc_random 
00268   end interface
00269   
00275   interface init   ! Définition
00276      module procedure v_init, v_init_fromfile
00277   end interface
00278   
00284   interface print   ! Définition
00285      module procedure v_print, v_print_tofile
00286   end interface
00287 
00288   !**** brief  exception signification of vector
00290   character(len=len_what_exception) :: v_what_exception
00291   
00292   !**** brief  infty constant representative
00294   integer, parameter :: infty = 0 ! for infty norm
00295 CONTAINS
00296 
00297   !**** brief subroutine v_init(v,size_v)
00305   subroutine v_init(v,size_v)
00306     implicit none
00307     type(vector) :: v;
00308     integer, intent(in), optional :: size_v;
00309     !local variables
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   !**** brief subroutine v_init_fromfile(v,filename,unit)
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     !local variables
00349     integer(kind=2)  :: ierr;
00350     type(type_exception) :: err_exception;
00351     integer :: in_unit
00352     integer :: i !loop index
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   !! open file
00364   open (unit=in_unit,file=filename, form="formatted", action="read",status="unknown")     
00365   read (unit=in_unit,fmt=*,end=1000)v%size   !read size (first line)
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) !!close file 
00381     v%is_allocate = allocated(v%ptr_container)    
00382 end if
00383   end subroutine v_init_fromfile
00384 
00385     
00386   !**** brief subroutine v_resize(v,size_v)
00393   subroutine v_resize(v,size_v)
00394     implicit none
00395     type(vector),intent(inout) :: v;
00396     integer, intent(in) :: size_v;
00397     !local variables
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   !**** brief subroutine v_destruct(v)
00426   subroutine v_destruct(v)
00427     implicit none
00428     type(vector) :: v;
00429     !local variables
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   !**** brief subroutine vc_random(v,low,high)
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     !local variables
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; !default
00473 end if
00474 if(present(high)) then
00475         in_high=high;
00476 else
00477         in_high=v%size; !default
00478 end if
00479 ! seed should be set to a large odd integer according to the manual
00480 ! secnds(x) gives number of seconds-x elapsed since midnight
00481 
00482 ! the 2*int(secnds(x)) is always even (int=gives integer) so seed is always odd
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   !**** brief function v_ones(size_v) result (res)
00495   function v_ones(size_v) result(res)
00496     implicit none
00497     integer, intent(in) :: size_v;
00498     !local variables
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   !**** brief subroutine v_init_value(v,value) result (res)
00528   subroutine v_init_value(v,value)
00529     implicit none
00530     type_precision,intent(in) :: value
00531     type(vector) :: v;
00532     !local variables
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   !**** brief subroutine v_zeros(size_v) result (res)
00550   function v_zeros(size_v) result(res)
00551     implicit none
00552     integer, intent(in) :: size_v;
00553     !local variables
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   !**** brief subroutine v_add_val_end(v,val)
00577   subroutine v_add_val_end(v,val)
00578     implicit none
00579     type(vector),intent(inout) :: v;
00580     type_precision, intent(in) :: val; !val to add into v
00581     !local variables
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   !**** brief function v_extract(m,l_bound,u_bound) result (res)
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     !local variables
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   !**** brief function v_get(i) result (res)
00640   function v_get(v,i) result (res)
00641     type(vector), intent(in)   :: v
00642     integer, intent(in)   :: i   
00643     !local variables
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   !**** brief function v_get_v(v) result (res)
00666   function v_get_v(v) result (res)
00667     type(vector), intent(in)   :: v
00668     !local variables
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   !**** brief subroutine v_set(v,i,value) 
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     !local variables
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   !**** brief subroutine v_affect(v,value) 
00714   subroutine v_affect(v,value) 
00715     type(vector), intent(inout)   :: v
00716     type_precision, intent(in)   :: value
00717     !local variables
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   !*                                 utilities                                  *!    
00730   !******************************************************************************!   
00731 
00732   !**** brief function v_size(v) result (nb)
00739   function v_size(v) result (nb)
00740     type(vector), intent(in)   :: v
00741     !local variables
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   !**** brief function v_nbnegative(v) result (nb)
00760   function v_nbnegative(v) result (nb)
00761     type(vector), intent(in)   :: v
00762     !local variables
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   !**** brief function v_nbpositive(v) result (nb)
00781   function v_nbpositive(v) result (nb)
00782     type(vector), intent(in)   :: v
00783     !local variables
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   !**** brief function v_nbzeros(m) result (nb)
00802   function v_nbzeros(v) result (nb)
00803     type(vector), intent(in)   :: v
00804     !local variables
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   !**** brief function v_max(v) result (val)
00823   function v_max(v) result (val)
00824     type(vector), intent(in)   :: v
00825     !local variables
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   !**** brief function v_min(v) result (val)
00844   function v_min(v) result (val)
00845     type(vector), intent(in)   :: v
00846     !local variables
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   !**** brief function v_abs(v) result (res)
00865   function v_abs(v) result (res)
00866     type(vector), intent(in)   :: v
00867     !local variables
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   !**** brief function v_sum(v) result (val)
00889   function v_sum(v) result (val)
00890     type(vector), intent(in)   :: v
00891     !local variables
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   !**** brief function v_prod(v) result (val)
00911   function v_prod(v) result (val)
00912     type(vector), intent(in)   :: v
00913     !local variables
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   !*                                 treatments                                 *!    
00931   !******************************************************************************!
00932 
00933   !**** brief function v_inverse(v) result (res)
00940   function v_inverse(v) result (res)
00941     type(vector), intent(in)   :: v
00942     !local variables
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   !*                              Product vectors                              *!    
00961   !******************************************************************************!
00962 
00963   !**** brief function v_prod_vec(v1,v2) result (res)
00971   function v_prod_vec (v1,v2) result (res)
00972     implicit none
00973     type(vector),intent(in) :: v1,v2
00974     type(vector) :: res
00975     !local variables
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   !**** brief function v_prod_scalar1(v,alpha) result (res)
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     !local variables
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   !**** brief function v_prod_scalar2(alpha,v) result (res)
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     !local variables
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   !**** brief function v_div_scalar(v,alpha) result (res)
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     !local variables
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   !*                              Addition vectors                              *!    
01074   !******************************************************************************!  
01075 
01076   !**** brief function v_add(v1,v2) result (res)
01084   function v_add(v1,v2) result (res)
01085     implicit none
01086     type(vector),intent(in) :: v1,v2
01087     !local variables
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   !*                         soustraction vectors                               *!    
01106   !******************************************************************************!
01107 
01108   !**** brief function v_minus(v1,v2) result (res)
01116   function v_minus(v1,v2) result (res)
01117     implicit none
01118     type(vector),intent(in) :: v1,v2  
01119     !local variables
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   !*                                   a.x+b.y                                  *!    
01138   !******************************************************************************!
01139   
01140   !**** brief function v_axpby(alpha,x,beta,y) result (res)
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     !local variables
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   !*                                 vectors                                    *!    
01191   !******************************************************************************!
01192 
01193   !**** brief subroutine v_normalize(v) 
01199   subroutine v_normalize(v)
01200     type(vector), intent(inout)   :: v
01201     !local variables
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   !**** brief function v_sqrLength(v) result (res)
01219   function v_sqrLength(v) result (res)
01220     type(vector), intent(in)   :: v
01221     !local variables
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 !!$OMP PARALLEL DO NUM_THREADS(OMP_NUM_THREADS) PRIVATE(i) shared(v) reduction(+:res) 
01234     do i=1,v%size
01235        res = res + v%ptr_container(i)**2
01236     end do
01237 !!$OMP end PARALLEL DO
01238   end function v_sqrLength
01239 
01240 
01241   !**** brief function v_length(v) result (res)
01248   function v_length(v) result (res)
01249     type(vector), intent(in)   :: v
01250     !local variables
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 !!$OMP PARALLEL DO NUM_THREADS(OMP_NUM_THREADS) PRIVATE(i) shared(v) reduction(+:res) 
01262     do i=1,v%size
01263        res = res + v%ptr_container(i)**2
01264     end do
01265 !!$OMP end PARALLEL DO
01266     res=sqrt(real(res))
01267   end function v_length
01268 
01269   !**** brief function v_norm(v,type_norm) result (res)
01277   function v_norm(v,type_norm) result (res)
01278     type(vector), intent(in)   :: v
01279     integer, intent(in), optional  :: type_norm
01280     !local variables
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         !!$OMP PARALLEL DO NUM_THREADS(OMP_NUM_THREADS) PRIVATE(i) shared(v) reduction(+:res)   
01302             do i=1,v%size
01303                res = res + abs(v%ptr_container(i))**in_type_norm
01304             end do
01305         !!$OMP end PARALLEL DO
01306           res=res**(1.0/in_type_norm)
01307     end if
01308   end function v_norm
01309 
01310 
01311   !**** brief function v_dot(v1,v2) result (res)
01320   function v_dot(v1,v2) result (res)
01321     type(vector), intent(in)   :: v1, v2
01322     !local variables
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 !!$OMP PARALLEL DO NUM_THREADS(OMP_NUM_THREADS) PRIVATE(i) reduction(+:res)    
01334     do i=1,v1%size
01335        res = res + v1%ptr_container(i)*v2%ptr_container(i)
01336     end do
01337 !!$OMP end PARALLEL DO 
01338         
01339   end function v_dot
01340 
01341   !**** brief function v_cross(v1,v2) result (res)
01349   function v_cross(v1,v2) result (res)
01350     type(vector), intent(in)   :: v1, v2
01351     !local variables
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   !**** brief function v_isEqual(v1,v2) result (res)
01378   function v_isEqual(v1,v2) result (res)
01379     ! Fonction associée à operator .tr.
01380     type(vector), intent(in)   :: v1, v2
01381     !local variables
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   !**** brief function v_isEqual_scalar(v,val) result (res)
01407   function v_isEqual_scalar(v,val) result (res)
01408     ! Fonction associée à operator .tr.
01409     type(vector), intent(in)   :: v
01410     type_precision, intent(in) :: val
01411     !local variables
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   !*                               find functions                               *!    
01426   !******************************************************************************!
01427   
01428 
01429   !******************************************************************************!
01430   !*                        Display function v_s                                *!    
01431   !******************************************************************************!
01432 
01433   !**** brief v_print(v)
01440   subroutine v_print(v)
01441     implicit none
01442     type(vector), intent(in) :: v
01443     !local variables
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   !**** brief v_print_tofile(v,filename,unit)
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     !local variables
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   !open file
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  !size of vector
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) !close file
01509 
01510   end subroutine v_print_tofile
01511   
01512   
01513   !**** brief print_c(v)
01520   subroutine v_print_c(v)
01521     implicit none
01522     type(vector), intent(in) :: v
01523     !local variables
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   !**** brief v_print_c_tofile(v,filename,unit)
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     !local variables
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   !open file  
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  !size of vector
01585        write(in_unit,fmt=p_fmt_file) v%ptr_container 
01586   close(unit=in_unit) !close file
01587 
01588   end subroutine v_print_c_tofile
01589 
01590 end module mod_vector
01591 
01592  ! /***** list of examples for vector *****/
01593 
01597 
01601 
01605 
 All Classes Namespaces Files Functions Variables Defines