1* 2* $Id$ 3* 4#define NIL -1 5 6* *********************************************************** 7* * * 8* * nwpw_ilist library * 9* * * 10* * Author - Eric Bylaska * 11* * date - 10/09/01 * 12* * * 13* *********************************************************** 14 15* The nwpw_ilist library is a linked list for integer values. 16* 17* 18 19* *********************************** 20* * * 21* * nwpw_ilist_init * 22* * * 23* *********************************** 24 subroutine nwpw_ilist_init(mem) 25 implicit none 26 integer mem(2) 27 28 29* **** initialize list **** 30!!$OMP SINGLE 31 mem(1) = NIL 32 mem(2) = NIL 33!!OMP END SINGLE copyprivate(mem) 34!OMP BARRIER 35 36 return 37 end 38 39 40* *********************************** 41* * * 42* * nwpw_ilist_add * 43* * * 44* *********************************** 45 46 subroutine nwpw_ilist_add(mem,tag,ivalue) 47 implicit none 48#include "errquit.fh" 49 integer mem(2) 50 integer tag 51 integer ivalue 52 53#include "bafdecls.fh" 54 55 56* **** local variables **** 57 logical value 58 integer node(2),cur 59 character*16 id 60 61* **** allocate q_map,p_map,k_map ***** 62 id='ilist'//CHAR(ICHAR('a')+tag) 63 value = BA_alloc_get(mt_int,4,id,node(2),node(1)) 64 if (.not. value) then 65 call errquit('nwpw_ilist_add: out of heap memory',0, MA_ERR) 66 end if 67 68 int_mb(node(1)) = NIL 69 int_mb(node(1)+1) = NIL 70 int_mb(node(1)+2) = tag 71 int_mb(node(1)+3) = ivalue 72 73 74* *** add to the end of list *** 75 if (mem(1).eq.NIL) then 76 mem(1) = node(1) 77 mem(2) = node(2) 78 else 79 cur = mem(1) 80 do while (int_mb(cur).ne.NIL) 81 cur = int_mb(cur) 82 end do 83 int_mb(cur) = node(1) 84 int_mb(cur+1) = node(2) 85 end if 86 87 return 88 end 89 90* *********************************** 91* * * 92* * nwpw_ilist_get * 93* * * 94* *********************************** 95 subroutine nwpw_ilist_get(mem,tag,ivalue) 96 implicit none 97#include "errquit.fh" 98 integer mem(2) 99 integer tag 100 integer ivalue 101 102#include "bafdecls.fh" 103 104* **** local variables **** 105 integer cur 106 107 cur = mem(1) 108 if (cur.eq.NIL) then 109 call errquit('nwpw_ilist_get: empty list',0, MEM_ERR) 110 end if 111 112 do while ((int_mb(cur+2).ne.tag).and. 113 > (int_mb(cur).ne.NIL)) 114 cur = int_mb(cur) 115 end do 116 117* **** error - tag not found **** 118 if (int_mb(cur+2).ne.tag) then 119 write(*,*) 'tag,mem:',tag,mem 120 call errquit('nwpw_ilist_get: tag not found',0, INT_ERR) 121 end if 122 123 ivalue = int_mb(cur+3) 124 125 return 126 end 127 128 129* *********************************** 130* * * 131* * nwpw_ilist_delete * 132* * * 133* *********************************** 134 135 subroutine nwpw_ilist_delete(mem,tag) 136 implicit none 137#include "errquit.fh" 138 integer mem(2) 139 integer tag 140 141#include "bafdecls.fh" 142 143* **** local variables **** 144 integer cur,prev,del_node(2),next(2) 145 146 prev = mem(1) 147 cur = mem(1) 148 if (cur.eq.NIL) then 149 write(*,*) 'warning empty ilist, tag,mem:',tag,mem 150 return 151 end if 152 153* *** delete first node **** 154 if (int_mb(cur+2).eq.tag) then 155 del_node(1) = mem(1) 156 del_node(2) = mem(2) 157 mem(1) = int_mb(cur) 158 mem(2) = int_mb(cur+1) 159 160* *** delete after first node **** 161 else 162 do while ((int_mb(cur+2).ne.tag).and. 163 > (int_mb(cur).ne.NIL)) 164 prev = cur 165 cur = int_mb(cur) 166 end do 167 168* **** error - tag not found **** 169 if (int_mb(cur+2).ne.tag) then 170 write(*,*) 'tag,mem:',tag,mem 171 call errquit('nwpw_ilist_get: tag not found',0, INT_ERR) 172 end if 173 174 del_node(1) = int_mb(prev) 175 del_node(2) = int_mb(prev+1) 176 next(1) = int_mb(cur) 177 next(2) = int_mb(cur+1) 178 179 int_mb(prev) = next(1) 180 int_mb(prev+1) = next(2) 181 end if 182 183* **** remove node from heap **** 184 if (.not.BA_free_heap(del_node(2))) then 185 call errquit('nwpw_ilist_delete: cannot free heap',0, MA_ERR) 186 end if 187 188 return 189 end 190 191 192 193