|
CP2K 2.4 (Revision 12889)
|
00001 !-----------------------------------------------------------------------------! 00002 ! CP2K: A general program to perform molecular dynamics simulations ! 00003 ! Copyright (C) 2000 - 2013 CP2K developers group ! 00004 !-----------------------------------------------------------------------------! 00005 00006 ! ***************************************************************************** 00013 MODULE machine_g95 00014 USE ISO_C_BINDING, ONLY: C_INT64_T 00015 USE f77_blas 00016 USE kinds, ONLY: dp,& 00017 int_8 00018 00019 IMPLICIT NONE 00020 00021 INTEGER(KIND=C_INT64_T), bind(C, name='_g95_total_alloc') :: total_memory 00022 00023 PRIVATE 00024 00025 PUBLIC :: m_cputime, m_flush, m_memory, & 00026 m_hostnm, m_getcwd, m_getlog, m_getuid, m_getpid, m_getarg, & 00027 m_iargc, m_abort, m_chdir, m_loc_r, m_loc_c, total_memory,m_mov, m_memory_details, & 00028 m_procrun 00029 00030 CONTAINS 00031 00032 ! ***************************************************************************** 00033 FUNCTION m_loc_r(a) RESULT(res) 00034 REAL(KIND=dp), DIMENSION(*), INTENT(in) :: a 00035 INTEGER :: res 00036 00037 res=LOC(a) 00038 END FUNCTION m_loc_r 00039 00040 ! ***************************************************************************** 00041 FUNCTION m_loc_c(a) RESULT(res) 00042 COMPLEX(KIND=dp), DIMENSION(*), 00043 INTENT(in) :: a 00044 INTEGER :: res 00045 00046 res=LOC(a) 00047 END FUNCTION m_loc_c 00048 00049 ! can be used to get a nice core 00050 ! ***************************************************************************** 00051 SUBROUTINE m_abort() 00052 CALL abort() 00053 END SUBROUTINE m_abort 00054 00055 ! the number of arguments of the fortran program 00056 ! ***************************************************************************** 00057 FUNCTION m_iargc() RESULT (ic) 00058 INTEGER :: ic 00059 00060 INTEGER :: iargc 00061 00062 ic = iargc() 00063 END FUNCTION m_iargc 00064 00065 !! cpu time in seconds 00066 ! ***************************************************************************** 00067 FUNCTION m_cputime() RESULT (ct) 00068 REAL(KIND=dp) :: ct 00069 00070 CALL CPU_TIME(ct) 00071 END FUNCTION m_cputime 00072 00073 ! flush a given unit 00074 ! ***************************************************************************** 00075 SUBROUTINE m_flush(lunit) 00076 INTEGER, INTENT(IN) :: lunit 00077 00078 CALL flush(lunit) 00079 END SUBROUTINE m_flush 00080 00081 ! returns the total amount of memory [bytes] in use, if known, zero otherwise 00082 ! ***************************************************************************** 00083 FUNCTION m_memory() 00084 00085 INTEGER(KIND=int_8) :: m_memory 00086 00087 ! 00088 ! __NO_STATM_ACCESS can be used to disable the stuff, if getpagesize 00089 ! lead to linking errors or /proc/self/statm can not be opened 00090 ! 00091 #if defined(__NO_STATM_ACCESS) || defined (__HAS_NO_ISO_C_BINDING) 00092 m_memory=total_memory 00093 #else 00094 CHARACTER(LEN=80) :: DATA 00095 INTEGER :: iostat,i 00096 00097 ! the size of a page, might not be available everywhere 00098 INTERFACE 00099 FUNCTION getpagesize() BIND(C,name="getpagesize") RESULT(RES) 00100 USE ISO_C_BINDING 00101 INTEGER(C_INT) :: RES 00102 END FUNCTION 00103 END INTERFACE 00104 00105 ! 00106 ! reading from statm 00107 ! 00108 m_memory=-1 00109 DATA="" 00110 OPEN(121245,FILE="/proc/self/statm",ACTION="READ",STATUS="OLD",ACCESS="STREAM") 00111 DO I=1,80 00112 READ(121245,END=999) DATA(I:I) 00113 ENDDO 00114 999 CLOSE(121245) 00115 DATA(I:80)="" 00116 READ(DATA,*,IOSTAT=iostat) m_memory 00117 IF (iostat.NE.0) THEN 00118 m_memory=0 00119 ELSE 00120 m_memory=m_memory*getpagesize() 00121 ENDIF 00122 #endif 00123 00124 END FUNCTION m_memory 00125 00126 ! *** get more detailed memory info, all units are bytes. 00127 ! *** the only 'useful' option is MemLikelyFree which is an estimate of remaining memory 00128 ! *** assumed to give info like /proc/meminfo while MeMLikelyFree is the amount of 00129 ! *** memory we're likely to be able to allocate, but not necessarily in one chunk 00130 ! *** zero means not available 00131 SUBROUTINE m_memory_details(MemTotal,MemFree,Buffers,Cached,Slab,SReclaimable,MemLikelyFree) 00132 00133 INTEGER(kind=int_8), OPTIONAL :: MemTotal,MemFree,Buffers,Cached,Slab,SReclaimable,MemLikelyFree 00134 00135 INTEGER, PARAMETER :: Nbuffer=10000 00136 CHARACTER(LEN=Nbuffer) :: meminfo 00137 00138 00139 INTEGER :: i 00140 00141 MemTotal=0 00142 MemFree=0 00143 Buffers=0 00144 Cached=0 00145 Slab=0 00146 SReclaimable=0 00147 MemLikelyFree=0 00148 meminfo="" 00149 00150 OPEN(UNIT=8123,file="/proc/meminfo",ACCESS="STREAM",ERR=901) 00151 i=0 00152 DO 00153 i=i+1 00154 IF (i>Nbuffer) EXIT 00155 READ(8123,END=900,ERR=900) meminfo(i:i) 00156 ENDDO 00157 900 CONTINUE 00158 meminfo(i:Nbuffer)="" 00159 901 CONTINUE 00160 CLOSE(8123,ERR=902) 00161 902 CONTINUE 00162 MemTotal=get_field_value_in_bytes('MemTotal:') 00163 MemFree=get_field_value_in_bytes('MemFree:') 00164 Buffers=get_field_value_in_bytes('Buffers:') 00165 Cached=get_field_value_in_bytes('Cached:') 00166 Slab=get_field_value_in_bytes('Slab:') 00167 SReclaimable=get_field_value_in_bytes('SReclaimable:') 00168 ! opinions here vary but this might work 00169 MemLikelyFree=MemFree+Buffers+Cached+SReclaimable 00170 00171 00172 CONTAINS 00173 INTEGER(int_8) FUNCTION get_field_value_in_bytes(field) 00174 CHARACTER(LEN=*) :: field 00175 INTEGER :: start 00176 INTEGER(KIND=8) :: value 00177 get_field_value_in_bytes=0 00178 start=INDEX(meminfo,field) 00179 IF (start.NE.0) THEN 00180 start=start+LEN_TRIM(field) 00181 IF (start.LT.Nbuffer) THEN 00182 READ(meminfo(start:),*,ERR=999,END=999) value 00183 ! XXXXXXX convert from Kb to bytes XXXXXXXX 00184 get_field_value_in_bytes=value*1024 00185 999 CONTINUE 00186 ENDIF 00187 ENDIF 00188 END FUNCTION 00189 END SUBROUTINE m_memory_details 00190 00191 ! returns if a process is running on the local machine 00192 ! 1 if yes and 0 if not 00193 00194 INTEGER FUNCTION m_procrun(id) RESULT (run_on) 00195 INTEGER :: id, ios 00196 CHARACTER(len=80) :: filename, tmp 00197 CHARACTER(len=8) :: id_s 00198 00199 WRITE(id_s,'(I8)') id 00200 00201 id_s = ADJUSTL(id_s) 00202 00203 tmp = "/proc/" // TRIM(id_s) // "/stat" 00204 filename = TRIM(tmp) 00205 00206 OPEN(87,FILE=filename,ACTION="READ", STATUS="OLD", IOSTAT=ios) 00207 IF (ios /= 0) THEN 00208 run_on = 0 00209 ELSE 00210 run_on = 1 00211 CLOSE(87) 00212 ENDIF 00213 00214 END FUNCTION m_procrun 00215 00216 00217 ! ***************************************************************************** 00218 SUBROUTINE m_mov(source,TARGET) 00219 00220 CHARACTER(LEN=*), INTENT(IN) :: source, TARGET 00221 00222 CALL rename(TRIM(source),TRIM(TARGET)) 00223 00224 END SUBROUTINE m_mov 00225 00226 ! ***************************************************************************** 00227 SUBROUTINE m_hostnm(hname) 00228 CHARACTER(len=*), INTENT(OUT) :: hname 00229 00230 INTEGER :: hostnm, ierror 00231 00232 ierror=hostnm(hname) 00233 END SUBROUTINE m_hostnm 00234 00235 ! ***************************************************************************** 00236 SUBROUTINE m_getcwd(curdir) 00237 CHARACTER(len=*), INTENT(OUT) :: curdir 00238 00239 INTEGER :: getcwd, ierror 00240 00241 ierror = getcwd(curdir) 00242 END SUBROUTINE m_getcwd 00243 00244 ! ***************************************************************************** 00245 SUBROUTINE m_chdir(dir,ierror) 00246 CHARACTER(len=*), INTENT(IN) :: dir 00247 INTEGER, INTENT(OUT) :: ierror 00248 00249 INTEGER :: chdir 00250 00251 ierror = chdir(dir) 00252 END SUBROUTINE m_chdir 00253 00254 ! ***************************************************************************** 00255 SUBROUTINE m_getlog(user) 00256 CHARACTER(len=*), INTENT(OUT) :: user 00257 00258 CALL getlog(user) 00259 END SUBROUTINE m_getlog 00260 00261 ! ***************************************************************************** 00262 SUBROUTINE m_getuid(uid) 00263 INTEGER, INTENT(OUT) :: uid 00264 00265 INTEGER :: getuid 00266 00267 uid = getuid() 00268 END SUBROUTINE m_getuid 00269 00270 ! ***************************************************************************** 00271 SUBROUTINE m_getpid(pid) 00272 INTEGER, INTENT(OUT) :: pid 00273 00274 INTEGER :: getpid 00275 00276 pid = getpid() 00277 END SUBROUTINE m_getpid 00278 00279 ! ***************************************************************************** 00280 SUBROUTINE m_getarg(i,arg) 00281 INTEGER, INTENT(IN) :: i 00282 CHARACTER(len=*), INTENT(OUT) :: arg 00283 00284 CALL getarg(i,arg) 00285 END SUBROUTINE m_getarg 00286 00287 END MODULE machine_g95 00288
1.7.3