module mem_manager use model_info use datatype implicit none real(8), parameter :: no_def_value = 1.0D0 !--FOR x integer, save :: current_addr_x = 1 integer, save :: max_addr_x real(8),dimension(:,:,:,:), allocatable, save :: work_x logical, dimension(:), allocatable, save :: free_mask_x integer, dimension(:), allocatable, save :: linked_counter_x !--FOR y integer, save :: current_addr_y = 1 integer, save :: max_addr_y real(8),dimension(:,:,:,:), allocatable, save :: work_y logical, dimension(:), allocatable, save :: free_mask_y integer, dimension(:), allocatable, save :: linked_counter_y !--FOR z integer, save :: current_addr_z = 1 integer, save :: max_addr_z real(8),dimension(:,:,:,:), allocatable, save :: work_z logical, dimension(:), allocatable, save :: free_mask_z integer, dimension(:), allocatable, save :: linked_counter_z !--FOR xy integer, save :: current_addr_xy = 1 integer, save :: max_addr_xy real(8),dimension(:,:,:,:), allocatable, save :: work_xy logical, dimension(:), allocatable, save :: free_mask_xy integer, dimension(:), allocatable, save :: linked_counter_xy !--FOR xz integer, save :: current_addr_xz = 1 integer, save :: max_addr_xz real(8),dimension(:,:,:,:), allocatable, save :: work_xz logical, dimension(:), allocatable, save :: free_mask_xz integer, dimension(:), allocatable, save :: linked_counter_xz !--FOR yz integer, save :: current_addr_yz = 1 integer, save :: max_addr_yz real(8),dimension(:,:,:,:), allocatable, save :: work_yz logical, dimension(:), allocatable, save :: free_mask_yz integer, dimension(:), allocatable, save :: linked_counter_yz !--FOR xyz integer, save :: current_addr_xyz = 1 integer, save :: max_addr_xyz real(8),dimension(:,:,:,:), allocatable, save :: work_xyz logical, dimension(:), allocatable, save :: free_mask_xyz integer, dimension(:), allocatable, save :: linked_counter_xyz contains !--FOR x (1,0,0) subroutine allocate_work_area_x(max_address) integer, intent(in) :: max_address integer :: work_i, mask_i, counter_i allocate( work_x(lb_axis1:ub_axis1, 1, 1, max_address), stat=work_i ) allocate( free_mask_x(max_address), stat=mask_i ) allocate( linked_counter_x(max_address), stat=counter_i ) if (work_i /= 0 .or. mask_i /= 0 .or. counter_i /=0) then write(*,*)'[WARNING]work area X is NOT allocated!!' end if free_mask_x = .true. linked_counter_x = 0 work_x = no_def_value max_addr_x = max_address end subroutine allocate_work_area_x !--FOR Y (0,1,0) subroutine allocate_work_area_y(max_address) integer, intent(in) :: max_address integer :: work_i, mask_i, counter_i allocate( work_y(1, lb_axis2:ub_axis2, 1, max_address), stat=work_i ) allocate( free_mask_y(max_address), stat=mask_i ) allocate( linked_counter_y(max_address), stat=counter_i ) if (work_i /= 0 .or. mask_i /= 0 .or. counter_i /=0) then write(*,*)'[WARNING]work area Y is NOT allocated!!' end if free_mask_y = .true. linked_counter_y = 0 work_y = no_def_value max_addr_y = max_address end subroutine allocate_work_area_y !--FOR Z (0,0,1) subroutine allocate_work_area_z(max_address) integer, intent(in) :: max_address integer :: work_i, mask_i, counter_i allocate( work_z(1, 1, lb_axis3:ub_axis3, max_address), stat=work_i ) allocate( free_mask_z(max_address), stat=mask_i ) allocate( linked_counter_z(max_address), stat=counter_i ) if (work_i /= 0 .or. mask_i /= 0 .or. counter_i /=0) then write(*,*)'[WARNING]work area Z is NOT allocated!!' end if free_mask_z = .true. linked_counter_z = 0 work_z = no_def_value max_addr_z = max_address end subroutine allocate_work_area_z !--FOR XY(1,1,0) subroutine allocate_work_area_xy(max_address) integer, intent(in) :: max_address integer :: work_i, mask_i, counter_i allocate( work_xy(lb_axis1:ub_axis1, lb_axis2:ub_axis2, 1, max_address), stat=work_i ) allocate( free_mask_xy(max_address), stat=mask_i ) allocate( linked_counter_xy(max_address), stat=counter_i ) if (work_i /= 0 .or. mask_i /= 0 .or. counter_i /=0) then write(*,*)'[WARNING]work area XY is NOT allocated!!' end if free_mask_xy = .true. linked_counter_xy = 0 work_xy = no_def_value max_addr_xy = max_address end subroutine allocate_work_area_xy !--FOR XZ(1,0,1) subroutine allocate_work_area_xz(max_address) integer, intent(in) :: max_address integer :: work_i, mask_i, counter_i allocate( work_xz(lb_axis1:ub_axis1, 1, lb_axis3:ub_axis3, max_address), stat=work_i ) allocate( free_mask_xz(max_address), stat=mask_i ) allocate( linked_counter_xz(max_address), stat=counter_i ) if (work_i /= 0 .or. mask_i /= 0 .or. counter_i /=0) then write(*,*)'[WARNING]work area XZ is NOT allocated!!' end if free_mask_xz = .true. linked_counter_xz = 0 work_xz = no_def_value max_addr_xz = max_address end subroutine allocate_work_area_xz !--FOR YZ (0,1,1) subroutine allocate_work_area_yz(max_address) integer, intent(in) :: max_address integer :: work_i, mask_i, counter_i allocate( work_yz(1, lb_axis2:ub_axis2, lb_axis3:ub_axis3, max_address), stat=work_i ) allocate( free_mask_yz(max_address), stat=mask_i ) allocate( linked_counter_yz(max_address), stat=counter_i ) if (work_i /= 0 .or. mask_i /= 0 .or. counter_i /=0) then write(*,*)'[WARNING]work area YZ is NOT allocated!!' end if free_mask_yz = .true. linked_counter_yz = 0 work_yz = no_def_value max_addr_yz = max_address end subroutine allocate_work_area_yz !--FOR XYZ(1,1,1) subroutine allocate_work_area_xyz(max_address) integer, intent(in) :: max_address integer :: work_i, mask_i, counter_i allocate( work_xyz(lb_axis1:ub_axis1,lb_axis2:ub_axis2,lb_axis3:ub_axis3,max_address), stat=work_i ) allocate( free_mask_xyz(max_address), stat=mask_i ) allocate( linked_counter_xyz(max_address), stat=counter_i ) if (work_i /= 0 .or. mask_i /= 0 .or. counter_i /=0) then write(*,*)'[WARNING]work area XYZ is NOT allocated!!' end if free_mask_xyz = .true. linked_counter_xyz = 0 work_xyz = no_def_value max_addr_xyz = max_address end subroutine allocate_work_area_xyz !----------------------- ! ! Set_save_var ! ! work area上で計算結果に対応する値が入っているアドレスには印を付けておく。 ! 一番最初はユーザーがこれを行わないといけない。 ! !----------------------- !--- FOR X subroutine set_save_var_x(invar) type(var_x) :: invar do if ( free_mask_x(current_addr_x) ) exit current_addr_x = current_addr_x + 1 if ( current_addr_x > max_addr_x ) stop 'working area X' end do invar%id = current_addr_x free_mask_x(current_addr_x) = .false. linked_counter_x(current_addr_x) = 1 current_addr_x = current_addr_x + 1 end subroutine set_save_var_x !--- FOR Y subroutine set_save_var_y(invar) type(var_y) :: invar do if ( free_mask_y(current_addr_y) ) exit current_addr_y = current_addr_y + 1 if ( current_addr_y > max_addr_y ) stop 'working area Y' end do invar%id = current_addr_y free_mask_y(current_addr_y) = .false. linked_counter_y(current_addr_y) = 1 current_addr_y = current_addr_y + 1 end subroutine set_save_var_y !--- FOR Z subroutine set_save_var_z(invar) type(var_z) :: invar do if ( free_mask_z(current_addr_z) ) exit current_addr_z = current_addr_z + 1 if ( current_addr_z > max_addr_z ) stop 'working area Z' end do invar%id = current_addr_z free_mask_z(current_addr_z) = .false. linked_counter_z(current_addr_z) = 1 current_addr_z = current_addr_z + 1 end subroutine set_save_var_z !--- FOR XY subroutine set_save_var_xy(invar) type(var_xy) :: invar do if ( free_mask_xy(current_addr_xy) ) exit current_addr_xy = current_addr_xy + 1 if ( current_addr_xy > max_addr_xy ) stop 'working area XY' end do invar%id = current_addr_xy free_mask_xy(current_addr_xy) = .false. linked_counter_xy(current_addr_xy) = 1 current_addr_xy = current_addr_xy + 1 end subroutine set_save_var_xy !--- FOR XZ subroutine set_save_var_xz(invar) type(var_xz) :: invar do if ( free_mask_xz(current_addr_xz) ) exit current_addr_xz = current_addr_xz + 1 if ( current_addr_xz > max_addr_xz ) stop 'working area XZ' end do invar%id = current_addr_xz free_mask_xz(current_addr_xz) = .false. linked_counter_xz(current_addr_xz) = 1 current_addr_xz = current_addr_xz + 1 end subroutine set_save_var_xz !--- FOR YZ subroutine set_save_var_yz(invar) type(var_yz) :: invar do if ( free_mask_yz(current_addr_yz) ) exit current_addr_yz = current_addr_yz + 1 if ( current_addr_yz > max_addr_yz ) stop 'working area YZ' end do invar%id = current_addr_yz free_mask_yz(current_addr_yz) = .false. linked_counter_yz(current_addr_yz) = 1 current_addr_yz = current_addr_yz + 1 end subroutine set_save_var_yz !--- FOR XYZ subroutine set_save_var_xyz(invar) type(var_xyz) :: invar do if ( free_mask_xyz(current_addr_xyz) ) exit current_addr_xyz = current_addr_xyz + 1 if ( current_addr_xyz > max_addr_xyz ) stop 'working area XYZ' end do invar%id = current_addr_xyz free_mask_xyz(current_addr_xyz) = .false. linked_counter_xyz(current_addr_xyz) = 1 current_addr_xyz = current_addr_xyz + 1 end subroutine set_save_var_xyz !------------------------------ ! ! Get_new_id ! ! work area 上のあいてるアドレスを問い合わせる ! ! 0割をさけるためそのアドレスには0でない値no_def_valueを代入しておく。 !------------------------------ !-- FOR X subroutine get_new_id_x(new_id) integer :: new_id do if (free_mask_x(current_addr_x)) exit current_addr_x = current_addr_x + 1 if (current_addr_x > max_addr_x) stop 'working area X' end do new_id = current_addr_x work_x(:,:,:,new_id) = no_def_value current_addr_x = current_addr_x + 1 end subroutine get_new_id_x !-- FOR Y subroutine get_new_id_y(new_id) integer :: new_id do if (free_mask_y(current_addr_y)) exit current_addr_y = current_addr_y + 1 if (current_addr_y > max_addr_y) stop 'working area Y' end do new_id = current_addr_y work_y(:,:,:,new_id) = no_def_value current_addr_y = current_addr_y + 1 end subroutine get_new_id_y !-- FOR Z subroutine get_new_id_z(new_id) integer :: new_id do if (free_mask_z(current_addr_z)) exit current_addr_z = current_addr_z + 1 if (current_addr_z > max_addr_z) stop 'working area Z' end do new_id = current_addr_z work_z(:,:,:,new_id) = no_def_value current_addr_z = current_addr_z + 1 end subroutine get_new_id_z !-- FOR XY subroutine get_new_id_xy(new_id) integer :: new_id do if (free_mask_xy(current_addr_xy)) exit current_addr_xy = current_addr_xy + 1 if (current_addr_xy > max_addr_xy) stop 'working area XY' end do new_id = current_addr_xy work_xy(:,:,:,new_id) = no_def_value current_addr_xy = current_addr_xy + 1 end subroutine get_new_id_xy !-- FOR XZ subroutine get_new_id_xz(new_id) integer :: new_id do if (free_mask_xz(current_addr_xz)) exit current_addr_xz = current_addr_xz + 1 if (current_addr_xz > max_addr_xz) stop 'working area XZ' end do new_id = current_addr_xz work_xz(:,:,:,new_id) = no_def_value current_addr_xz = current_addr_xz + 1 end subroutine get_new_id_xz !-- FOR YZ subroutine get_new_id_yz(new_id) integer :: new_id do if (free_mask_yz(current_addr_yz)) exit current_addr_yz = current_addr_yz + 1 if (current_addr_yz > max_addr_yz) stop 'working area YZ' end do new_id = current_addr_yz work_yz(:,:,:,new_id) = no_def_value current_addr_yz = current_addr_yz + 1 end subroutine get_new_id_yz !-- FOR XYZ subroutine get_new_id_xyz(new_id) integer :: new_id do if (free_mask_xyz(current_addr_xyz)) exit current_addr_xyz = current_addr_xyz + 1 if (current_addr_xyz > max_addr_xyz) stop 'working area XYZ' end do new_id = current_addr_xyz work_xyz(:,:,:,new_id) = no_def_value current_addr_xyz = current_addr_xyz + 1 end subroutine get_new_id_xyz !--------------------- ! ! Free_mask_update ! ! work areaにつけられている計算結果の印を新しい場所に付け替える ! !--------------------- !-- FOR X subroutine free_mask_update_x(old_id, new_id) integer old_id, new_id free_mask_x(old_id) = .true. free_mask_x(new_id) = .false. end subroutine free_mask_update_x !-- FOR Y subroutine free_mask_update_y(old_id, new_id) integer old_id, new_id free_mask_y(old_id) = .true. free_mask_y(new_id) = .false. end subroutine free_mask_update_y !-- FOR Z subroutine free_mask_update_z(old_id, new_id) integer old_id, new_id free_mask_z(old_id) = .true. free_mask_z(new_id) = .false. end subroutine free_mask_update_z !-- FOR XY subroutine free_mask_update_xy(old_id, new_id) integer old_id, new_id free_mask_xy(old_id) = .true. free_mask_xy(new_id) = .false. end subroutine free_mask_update_xy !-- FOR XZ subroutine free_mask_update_xz(old_id, new_id) integer old_id, new_id free_mask_xz(old_id) = .true. free_mask_xz(new_id) = .false. end subroutine free_mask_update_xz !-- FOR YZ subroutine free_mask_update_yz(old_id, new_id) integer old_id, new_id free_mask_yz(old_id) = .true. free_mask_yz(new_id) = .false. end subroutine free_mask_update_yz !-- FOR XYZ subroutine free_mask_update_xyz(old_id, new_id) integer old_id, new_id free_mask_xyz(old_id) = .true. free_mask_xyz(new_id) = .false. end subroutine free_mask_update_xyz !------------------------ ! ! Garbege_collect ! ! ゴミ集め。やってるのはAddress counterを1にリセットするだけ。 ! !------------------------ ! !---FOR X subroutine garbege_collect current_addr_x = 1 !---FOR Y current_addr_y = 1 !---FOR Z current_addr_z = 1 !---FOR XY current_addr_xy = 1 !---FOR XZ current_addr_xz = 1 !---FOR YZ current_addr_yz = 1 !---FOR XYZ current_addr_xyz = 1 end subroutine garbege_collect end module mem_manager